From 34c54f4ecd32eebd4aa6a11378e47f65a72a36a5 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Mon, 28 Apr 2014 21:40:36 -0700 Subject: [PATCH] Add match expander for all polymorphic functions. Use it in tc-apply error messages. original commit: d6ef3d774c7f5fe18a0e33159c45f5c2d71f862e --- .../typed-racket/typecheck/tc-apply.rkt | 6 +-- .../typed-racket/types/match-expanders.rkt | 37 ++++++++++++++++++- 2 files changed, 38 insertions(+), 5 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt index d058b1c6..1ff7ed65 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt @@ -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)])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt index 386048b4..3a67d166 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt @@ -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)])))