From 8ea32c68f61a0bfad6b162302bc3c0ff28870361 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 30 Jan 2014 16:19:52 -0500 Subject: [PATCH] Improve TR lambda to accommodate type annotations The new `lambda` form allows all combinations of arguments with optional type annotations for all cases. --- .../typed-racket/base-env/prims.rkt | 111 ++++++++++++------ .../unit-tests/typecheck-tests.rkt | 40 +++++++ 2 files changed, 114 insertions(+), 37 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index 0d3aab2866..d2cd463194 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -1118,49 +1118,86 @@ This file defines two sorts of primitives. All of them are provided into any mod (values (mk #'let/cc) (mk #'let/ec)))) +;; Syntax classes for -lambda (begin-for-syntax - (define-syntax-class optional-arg - (pattern name:id #:attr value #f) - (pattern (name:id value:expr))) - (define-splicing-syntax-class lambda-args - #:attributes (required-pos - optional-pos - optional-kws - required-kws) - (pattern (~seq (~or pos:optional-arg (~seq kw:keyword key:optional-arg)) ...) - #:attr optional-pos (length (filter values (attribute pos.value))) - #:attr required-pos (- (length (filter values (attribute pos.name))) - (attribute optional-pos)) - #:attr optional-kws - (for/list ((kw (attribute kw)) - (kw-value (attribute key.value)) - #:when kw-value) - kw) - #:attr required-kws (remove* (attribute optional-kws) (attribute kw))))) + (define-splicing-syntax-class kw-formal + #:attributes (form id default type kw) + #:literals (:) + (pattern (~seq kw:keyword id:id) + #:with form #'(kw id) + #:attr default #f + #:attr type #f) + (pattern (~seq kw:keyword [id:id default:expr]) + #:with form #'(kw [id default]) + #:attr type #f) + (pattern (~seq kw:keyword [id:id : type:expr]) + #:with form #`(kw #,(type-label-property #'id #'type)) + #:attr default #f) + (pattern (~seq kw:keyword [id:id : type:expr default:expr]) + #:with form #`(kw [#,(type-label-property #'id #'type) default]))) + + (define-splicing-syntax-class mand-formal + #:description "lambda argument" + #:attributes (form id default type kw) + #:literals (:) + (pattern id:id + #:with form #'(id) + #:attr default #f + #:attr type #f + #:attr kw #f) + (pattern [id:id : type:expr] + #:with form #`(#,(type-label-property #'id #'type)) + #:attr default #f + #:attr kw #f) + (pattern :kw-formal)) + + (define-splicing-syntax-class opt-formal + #:description "optional lambda argument" + #:attributes (form id default type kw) + #:literals (:) + (pattern [id:id default:expr] + #:with form #'([id default]) + #:attr type #f + #:attr kw #f) + (pattern [id:id : type:expr default:expr] + #:with form #`([#,(type-label-property #'id #'type) default]) + #:attr kw #f) + (pattern :kw-formal)) + + (define-syntax-class rest-arg + #:description "rest argument" + #:attributes (form) + #:literals (:) + (pattern () #:attr form #'()) + (pattern rest:id #:attr form #'rest) + ;; FIXME: add a typed rest-arg case if a good syntax is found + ) + + (define-syntax-class lambda-formals + #:attributes (opt-property kw-property erased) + #:literals (:) + (pattern (mand:mand-formal ... opt:opt-formal ... . rest:rest-arg) + #:attr kw-property + (> (length (append (filter values (attribute mand.kw)) + (filter values (attribute opt.kw)))) + 0) + #:attr req-len (length (attribute mand)) + #:attr opt-len (length (attribute opt)) + #:attr opt-property + (list (attribute req-len) (attribute opt-len)) + #:attr erased #`(#,@(apply append (stx-map syntax->list #'(mand.form ...))) + #,@(apply append (stx-map syntax->list #'(opt.form ...))) + . rest.form)))) ;; annotation to help tc-expr pick out keyword functions (define-syntax (-lambda stx) (syntax-parse stx - [(_ formals . body) - (define d (syntax/loc stx (λ formals . body))) - (syntax-parse #'formals - [(~or (~and (args:lambda-args) (~bind (rest #f))) - (args:lambda-args . rest:id)) - (define kw-property - (> (+ (length (attribute args.required-kws)) - (length (attribute args.optional-kws))) - 0)) - (define opt-property - (and (> (attribute args.optional-pos) 0) - (list - (attribute args.required-pos) - (attribute args.optional-pos)))) - (opt-lambda-property - (kw-lambda-property d kw-property) - opt-property)] - ;; This is an error and will be caught by the real lambda - [_ d])])) + [(_ formals:lambda-formals . body) + (define d (syntax/loc stx (λ formals.erased . body))) + (if (attribute formals.kw-property) + (kw-lambda-property d (attribute formals.kw-property)) + (opt-lambda-property d (attribute formals.opt-property)))])) ;; do this ourselves so that we don't get the static bindings, diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index 86a3645cad..23e848a622 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -2059,6 +2059,46 @@ #:msg #rx"expected: String.*given: Any"] [tc-err (let () (tr:define (f x #:y y) y) (f "a")) #:msg #rx"Required keyword not supplied"] + + ;; test lambdas with mixed type expressions, typed keywords, typed + ;; optional arguments + ;; FIXME: support rest args + [tc-e (tr:lambda (x [y : String]) (string-append y "b")) + #:ret (ret (t:-> Univ -String -String) (-FS -top -bot))] + [tc-e (tr:lambda (x z [y : String]) (string-append y "b")) + #:ret (ret (t:-> Univ Univ -String -String) (-FS -top -bot))] + [tc-err (tr:lambda (x [y : String "a"] z) (string-append y "b")) + #:msg "expected optional lambda argument"] + #| FIXME: requires improvement in opt-lambda checker + [tc-e (tr:lambda (x [y : String "a"]) (string-append y "b")) + (->opt Univ [-String] -String)] + |# + [tc-e (tr:lambda (x #:y [y : String]) (string-append y "b")) + (->key Univ #:y -String #t -String)] + [tc-e (tr:lambda (x #:y [y : String "a"]) (string-append y "b")) + (->key Univ #:y -String #f -String)] + [tc-e (tr:lambda (x #:y [y : String] [z "z"]) (string-append y "b")) + (->optkey Univ [Univ] #:y -String #t -String)] + [tc-e (tr:lambda (x #:y [y : String "a"] [z "z"]) (string-append y "b")) + (->optkey Univ [Univ] #:y -String #f -String)] + [tc-e (tr:lambda (x [z "z"] #:y [y : String]) (string-append y "b")) + (->optkey Univ [Univ] #:y -String #t -String)] + [tc-e (tr:lambda (x [z "z"] #:y [y : String "a"]) (string-append y "b")) + (->optkey Univ [Univ] #:y -String #f -String)] + [tc-e (tr:lambda (x #:y [y : String] [z : String "z"]) (string-append y z)) + (->optkey Univ [-String] #:y -String #t -String)] + [tc-e (tr:lambda (x #:y [y : String "y"] [z : String "z"]) (string-append y z)) + (->optkey Univ [-String] #:y -String #f -String)] + [tc-e (tr:lambda (x [z : String "z"] #:y [y : String]) (string-append y z)) + (->optkey Univ [-String] #:y -String #t -String)] + [tc-e (tr:lambda (x [z : String "z"] #:y [y : String "a"]) (string-append y z)) + (->optkey Univ [-String] #:y -String #f -String)] + [tc-e (tr:lambda (x #:y [y : String] #:z [z : String]) (string-append y z)) + (->key Univ #:y -String #t #:z -String #t -String)] + [tc-e (tr:lambda (x #:y [y : String] #:z [z : String "z"]) (string-append y z)) + (->key Univ #:y -String #t #:z -String #f -String)] + [tc-e (tr:lambda (x #:y [y : String "y"] #:z [z : String "z"]) (string-append y z)) + (->key Univ #:y -String #f #:z -String #f -String)] ) (test-suite "tc-literal tests"