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

Add support for rest arguments in TR plain lambda

Browse Source 
Two caveats:
  * in some positions : is not accepted as a formal
    when used in combination with * as a formal
  * the quality of parse error messages for rest
    argument types is traded for better optional argument
    error messages
This commit is contained in:
Asumu Takikawa 2014-02-11 18:25:04 -05:00
parent ad4f6e1ea1
commit a3d818c748
3 changed files with 33 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/base-env/prims.rkt
View File

@ -72,6 +72,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
syntax/struct
"annotate-classes.rkt"
"../utils/tc-utils.rkt"
"../private/parse-classes.rkt"
"../private/syntax-properties.rkt"
"../types/utils.rkt"
"for-clauses.rkt"
@ -1169,15 +1170,20 @@ This file defines two sorts of primitives. All of them are provided into any mod
#:description "rest argument"
#:attributes (form)
#:literals (:)
(pattern () #:attr form #'())
;; specifying opaque here helps produce a better error
;; message for optional argumenents, but produces worse
;; error messages for rest arguments.
#:opaque
(pattern rest:id #:attr form #'rest)
;; FIXME: add a typed rest-arg case if a good syntax is found
)
(pattern (rest:id : type:expr :star)
#:attr form (type-label-property #'rest #'type)))
(define-syntax-class lambda-formals
#:attributes (opt-property kw-property erased)
#:literals (:)
(pattern (mand:mand-formal ... opt:opt-formal ... . rest:rest-arg)
(pattern (~or (mand:mand-formal ... opt:opt-formal ... . rest:rest-arg)
(~and (mand:mand-formal ... opt:opt-formal ...)
(~bind [rest.form #'()])))
#:attr kw-property
(ormap values (append (attribute mand.kw) (attribute opt.kw)))
#:attr opt-property

15
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt
View File

@ -173,10 +173,7 @@
[kw-type (in-list kw-args)])
(make-Keyword kw kw-type #t)))
(define rest-type
(and rest?
(if (equal? (last other-args) Univ)
Univ
-Bottom)))
(and rest? (last other-args)))
(make-Function
(list (make-arr* (take other-args non-kw-argc)
rng
@ -196,10 +193,7 @@
(define-values (mand-args opt-and-rest-args)
(split-at other-args mand-non-kw-argc))
(define rest-type
(and rest?
(if (equal? (last opt-and-rest-args) Univ)
Univ
-Bottom)))
(and rest? (last opt-and-rest-args)))
(define opt-types (take opt-and-rest-args opt-non-kw-argc))
(make-Function
(for/list ([to-take (in-range (add1 (length opt-types)))])
@ -301,10 +295,7 @@
(define-values (mand-args opt-and-rest-args)
(split-at doms mand-argc))
(define rest-type
(and rest?
(if (equal? (last opt-and-rest-args) Univ)
Univ
-Bottom)))
(and rest? (last opt-and-rest-args)))
(define opt-types (take opt-and-rest-args opt-argc))
(make-Function
(for/list ([to-take (in-range (add1 (length opt-types)))])

21
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -2062,13 +2062,20 @@
;; 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 [y : String] . z) (string-append y "b"))
#:ret (ret (->* (list Univ -String) Univ -String) (-FS -top -bot))]
[tc-e (tr:lambda (x [y : String] . [z : String *]) (string-append y "b"))
#:ret (ret (->* (list Univ -String) -String -String) (-FS -top -bot))]
[tc-e (tr:lambda (x [y : String]) : 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-e (tr:lambda (x z [y : String] . w) (string-append y "b"))
#:ret (ret (->* (list Univ Univ -String) Univ -String) (-FS -top -bot))]
[tc-e (tr:lambda (x z [y : String] . [w : String *]) (string-append y "b"))
#:ret (ret (->* (list Univ Univ -String) -String -String) (-FS -top -bot))]
[tc-e (tr:lambda (x z [y : String]) : String (string-append y "b"))
#:ret (ret (t:-> Univ Univ -String -String) (-FS -top -bot))]
[tc-err (tr:lambda (x [y : String]) : Symbol (string-append y "b"))
@ -2077,6 +2084,10 @@
#:msg "expected optional lambda argument"]
[tc-e (tr:lambda (x [y : String "a"]) (string-append y "b"))
(->opt Univ [-String] -String)]
[tc-e (tr:lambda (x [y : String "a"] . z) (string-append y "b"))
(->optkey Univ [-String] #:rest Univ -String)]
[tc-e (tr:lambda (x [y : String "a"] . [z : String *]) (string-append y "b"))
(->optkey Univ [-String] #:rest -String -String)]
[tc-e (tr:lambda (x y [z : String "a"]) (string-append z "b"))
(->opt Univ Univ [-String] -String)]
[tc-e (tr:lambda (w x [y : String "y"] [z : String "z"]) (string-append y z))
@ -2086,6 +2097,10 @@
(->opt Univ -String [-String -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] . z) (string-append y "b"))
(->optkey Univ [] #:rest Univ #:y -String #t -String)]
[tc-e (tr:lambda (x #:y [y : String] . [z : String *]) (string-append y "b"))
(->optkey Univ [] #:rest -String #:y -String #t -String)]
[tc-e (tr:lambda (x #:y [y : String]) : String (string-append y "b"))
(->key Univ #:y -String #t -String)]
[tc-e (tr:lambda (x #:y [y : String "a"]) (string-append y "b"))
@ -2104,6 +2119,10 @@
(->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] [z : String "z"] . w) (string-append y z))
(->optkey Univ [-String] #:rest Univ #:y -String #t -String)]
[tc-e (tr:lambda (x #:y [y : String] [z : String "z"] . [w : String *]) (string-append y z))
(->optkey Univ [-String] #:rest -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))