From 02dd958a697bf897a412f24547dfd07d11a62b72 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 7 Jan 2014 16:33:29 -0500 Subject: [PATCH] Add ->* type constructor for optional arguments --- .../base-env/base-types-extra.rkt | 2 +- .../typed-racket/base-env/prims.rkt | 2 +- .../typed-racket/private/parse-type.rkt | 31 +++++++++++++++++-- .../typed-racket/types/abbrev.rkt | 5 +-- .../unit-tests/parse-type-tests.rkt | 19 ++++++++++++ 5 files changed, 52 insertions(+), 7 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt index 57035b5cec..27e987de93 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt @@ -15,7 +15,7 @@ ;; special type names that are not bound to particular types (define-other-types - -> case-> U Rec All Opaque Vector + -> ->* case-> U Rec All Opaque Vector Parameterof List List* Class Values Instance Refinement pred Struct Struct-Type Top Bot) 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 37b35fc2ec..0d3aab2866 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 @@ -50,7 +50,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (require "../utils/require-contract.rkt" "colon.rkt" "../typecheck/internal-forms.rkt" - (rename-in racket/contract/base [-> c->] [case-> c:case->]) + (rename-in racket/contract/base [-> c->] [->* c->*] [case-> c:case->]) ;; contracted bindings to replace built-in ones (except-in "base-contracted.rkt" initialize-contracted) "top-interaction.rkt" diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt index 118395534f..50e55fc3e8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -39,6 +39,7 @@ (define-literal-syntax-class #:for-label List*) (define-literal-syntax-class #:for-label pred) (define-literal-syntax-class #:for-label ->) +(define-literal-syntax-class #:for-label ->*) (define-literal-syntax-class #:for-label case->^ (case-> case-lambda)) (define-literal-syntax-class #:for-label Rec) (define-literal-syntax-class #:for-label U) @@ -99,9 +100,12 @@ [(:All^ (_:id ...) _ _ _ ...) (tc-error "All: too many forms in body of All type")] [(:All^ . rest) (tc-error "All: bad syntax")])) -(define-splicing-syntax-class keyword-tys +(define-splicing-syntax-class mandatory-kw-tys (pattern (~seq k:keyword t:expr) - #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t)) + #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t))) + +(define-splicing-syntax-class keyword-tys + (pattern kw:mandatory-kw-tys #:attr Keyword (attribute kw.Keyword)) (pattern (~seq [k:keyword t:expr]) #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f))) @@ -371,7 +375,28 @@ doms (parse-values-type #'rng) #:kws (attribute kws.Keyword)))))] - + [(:->*^ + (dom:non-keyword-ty ... mand-kws:mandatory-kw-tys ...) + ;; this clause uses the syntax of mandatory keyword types to + ;; match the ->* contract, but they are optional + ;; (the code below swaps the boolean appropriately) + (~optional (opt-dom:non-keyword-ty ... opt-kws:mandatory-kw-tys ...)) + (~optional (~seq #:rest rest-type:non-keyword-ty)) + rng) + (define doms (for/list ([d (in-syntax #'(dom ...))]) + (parse-type d))) + (define opt-doms (if (attribute opt-dom) + (for/list ([d (in-syntax #'(opt-dom ...))]) + (parse-type d)) + null)) + (opt-fn doms opt-doms (parse-values-type #'rng) + #:rest (and (attribute rest-type) + (parse-type #'rest-type)) + #:kws (append (attribute mand-kws.Keyword) + (map (match-lambda [(Keyword: k t _) (make-Keyword k t #f)]) + (if (attribute opt-kws) + (attribute opt-kws.Keyword) + null))))] [id:identifier (cond ;; if it's a type variable, we just produce the corresponding reference (which is in the HT) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt index e0f8550a61..26f3948751 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt @@ -260,9 +260,10 @@ (define/decl -true-filter (-FS -top -bot)) (define/decl -false-filter (-FS -bot -top)) -(define (opt-fn args opt-args result) +(define (opt-fn args opt-args result #:rest [rest #f] #:kws [kws null]) (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))]) - (make-Function (list (make-arr* (append args (take opt-args i)) result)))))) + (make-Function (list (make-arr* (append args (take opt-args i)) result + #:rest rest #:kws kws)))))) (define-syntax-rule (->opt args ... [opt ...] res) (opt-fn (list args ...) (list opt ...) res)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt index f57cbd49f9..7827e098cc 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt @@ -147,6 +147,25 @@ [(-> Integer (All (X) (-> X X))) (t:-> -Integer (-poly (x) (t:-> x x)))] + ;; ->* types + [(->* (String Symbol) Void) (t:-> -String -Symbol -Void)] + [(->* (String Symbol) (String) Void) + (->opt -String -Symbol [-String] -Void)] + [(->* (String Symbol) (String Symbol) Void) + (->opt -String -Symbol [-String -Symbol] -Void)] + [(->* (String Symbol) (String) (values Void String)) + (->opt -String -Symbol [-String] (-values (list -Void -String)))] + [(->* (String Symbol) (String) #:rest Symbol Void) + (->optkey -String -Symbol [-String] #:rest -Symbol -Void)] + [(All (a) (->* (a Symbol) (String) #:rest Symbol Void)) + (-poly (a) (->optkey a -Symbol [-String] #:rest -Symbol -Void))] + [(->* (Integer) (String #:foo Integer) Void) + (->optkey -Integer [-String] #:foo -Integer #f -Void)] + [(->* (Integer #:bar Integer) (String) Void) + (->optkey -Integer [-String] #:bar -Integer #t -Void)] + [(->* (Integer #:bar Integer) (String #:foo Integer) Void) + (->optkey -Integer [-String] #:bar -Integer #t #:foo -Integer #f -Void)] + [(Opaque foo?) (make-Opaque #'foo?)] ;; PR 14122 [FAIL (Opaque 3)]