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

Redo the calculation of opt-lambda expansion.

Browse Source 
Closes PR 13661.
Closes PR 13584.

original commit: c910252fdff4d18343fc9b47334b4fd4423ae794
This commit is contained in:
Eric Dobson 2013-03-24 13:38:33 -07:00
parent a403b7f948
commit 6580635e35
7 changed files with 226 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
View File

@ -1115,24 +1115,51 @@ This file defines two sorts of primitives. All of them are provided into any mod
(quasisyntax/loc stx (#,l/c k.ann-name . body))]))
(values (mk #'let/cc) (mk #'let/ec))))
(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)))))
;; annotation to help tc-expr pick out keyword functions
(define-syntax (-lambda stx)
(syntax-parse stx
[(_ formals . body)
(define-values (has-kw? has-opt?)
(syntax-parse #'formals
((~or (~and rest:id (~bind ((args 1) null)))
(args ...)
(args ...+ . rest:id))
(define arg-list (syntax->list #'(args ...)))
(values
(ormap keyword? (map syntax-e arg-list))
(ormap syntax->list arg-list)))))
(opt-lambda-property
(kw-lambda-property
(syntax/loc stx (λ formals . body))
has-kw?)
has-opt?)]))
(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))))
(syntax-property
(syntax-property d 'kw-lambda kw-property)
'opt-lambda opt-property)]
;; This is an error and will be caught by the real lambda
[_ d])]))
;; do this ourselves so that we don't get the static bindings,
;; which are harder to typecheck

23
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -263,10 +263,9 @@
(let-values (((_) (~and find-app (#%plain-app find-method/who _ _ _))))
(#%plain-app _ _ args ...))))
(tc/send #'find-app #'rcvr #'meth #'(args ...) expected)]
;; kw/opt function def
[(let-values ([(_) fun])
. body)
#:when (or (kw-lambda-property form) (opt-lambda-property form))
;; kw function def
[(let-values ([(_) fun]) . body)
#:when (syntax-property form 'kw-lambda)
(match expected
[(tc-result1: (and f (or (Function: _)
(Poly: _ (Function: _)))))
@ -274,6 +273,22 @@
[(or (tc-results: _) (tc-any-results:))
(tc-error/expr "Keyword functions must have function type, given ~a" expected)])
expected]
;; opt function def
[(let-values ([(f) fun]) . body)
#:when (syntax-property form 'opt-lambda)
(define conv-type
(match expected
[(tc-result1: fun-type)
(match-define (list required-pos optional-pos)
(syntax-property form 'opt-lambda))
(opt-convert fun-type required-pos optional-pos)]
[_ #f]))
(match-define (tc-result1: returned-fun-type)
(if conv-type
(tc-expr/check/type #'fun conv-type)
(tc-expr #'fun)))
(with-lexical-env/extend (list #'f) (list returned-fun-type)
(tc-exprs/check (syntax->list #'body) expected))]
;; let
[(let-values ([(name ...) expr] ...) . body)
(tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)]

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

@ -2,9 +2,10 @@
(require "abbrev.rkt" "../rep/type-rep.rkt"
"union.rkt" "../utils/tc-utils.rkt"
racket/list racket/dict racket/match)
racket/list racket/set racket/dict racket/match)
;; convert : [Listof Keyword] [Listof Type] [Listof Type] [Option Type] [Option Type] -> (values Type Type)
;; convert : [Listof Keyword] [Listof Type] [Listof Type] [Option Type]
;; [Option Type] [Option (Pair Type symbol)] boolean -> Type
(define (convert kw-t plain-t opt-t rng rest drest split?)
(define-values (mand-kw-t opt-kw-t) (partition (match-lambda [(Keyword: _ _ m) m]) kw-t))
@ -57,13 +58,13 @@
[(Keyword: _ t _) (list (-val #f) (-val #f))]))
plain-t
(for/list ([t (in-list opt-t)]) (-val #f))
(for/list ([t (in-list opt-t)]) (-val #f))
;; the kw function protocol passes rest args as an explicit list
(if rest (-lst rest) empty))))
(if split?
(make-Function (list (make-arr* ts/true rng)
(make-arr* ts/false rng)))
(make-Function (list (make-arr* ts rng)))))
(for/list ([t (in-list opt-t)]) (-val #f)))))
(make-Function
(if split?
(remove-duplicates
(list (make-arr* ts/true rng #:rest rest #:drest drest)
(make-arr* ts/false rng #:rest rest #:drest drest)))
(list (make-arr* ts rng #:rest rest #:drest drest)))))
(define (prefix-of a b)
(define (rest-equal? a b)
@ -110,24 +111,59 @@
(dict-set d prefix (arg-diff prefix e))
(dict-set d e empty))))
(define (inner-kw-convert arrs split?)
(define table (find-prefixes arrs))
(define fns
(for/set ([(k v) (in-dict table)])
(match k
[(arr: mand rng rest drest kws)
(convert kws mand v rng rest drest split?)])))
(apply cl->* (set->list fns)))
(define (kw-convert ft #:split [split? #f])
(match ft
[(Function: arrs)
(define table (find-prefixes arrs))
(define fns
(for/list ([(k v) (in-dict table)])
(match k
[(arr: mand rng rest drest kws)
(convert kws mand v rng rest drest split?)])))
(apply cl->* fns)]
[(Poly-names: names (Function: arrs))
(define table (find-prefixes arrs))
(define fns
(for/list ([(k v) (in-dict table)])
(match k
[(arr: mand rng rest drest kws)
(convert kws mand v rng rest drest split?)])))
(make-Poly names (apply cl->* fns))]
[_ (int-err "kw-convert: non-function type ~a" ft)]))
(inner-kw-convert arrs split?)]
[(Poly-names: names f)
(make-Poly names (kw-convert f #:split split?))]
[(PolyDots-names: names f)
(make-PolyDots names (kw-convert f #:split split?))]))
(provide kw-convert)
(define ((opt-convert-arr required-pos optional-pos) arr)
(match arr
[(arr: args result #f #f '())
(define num-args (length args))
(and (>= num-args required-pos)
(<= num-args (+ required-pos optional-pos))
(let* ([required-args (take args required-pos)]
[opt-args (drop args required-pos)]
[missing-opt-args (- (+ required-pos optional-pos) num-args)]
[present-flags (map (λ (t) (-val #t)) opt-args)]
[missing-args (make-list missing-opt-args (-val #f))])
(make-arr (append required-args
opt-args
missing-args
present-flags
missing-args)
result
#f
#f
'())))]
[(arr: args result _ _ _) #f]))
(define (opt-convert ft required-pos optional-pos)
(let/ec exit
(let loop ((ft ft))
(match ft
[(Function: arrs)
(let ((arrs (map (opt-convert-arr required-pos optional-pos) arrs)))
(if (andmap values arrs)
(make-Function arrs)
(exit #f)))]
[(Poly-names: names f)
(make-Poly names (loop f))]
[(PolyDots-names: names f)
(make-PolyDots names (loop f))]
[t t]))))
(provide kw-convert opt-convert)

13
pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/succeed/pr13584.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang typed/racket
(: f (case->
(-> Boolean)
(Input-Port -> Boolean)
(Bytes -> Boolean)))
(define (f (p #f))
(cond ((input-port? p) #t)
((bytes? p) #f)
(else #f)))
(assert (call-with-input-bytes #"port" f))

2
pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/all-tests.rkt
View File

@ -11,6 +11,7 @@
"subst-tests.rkt" ;; pass
"infer-tests.rkt" ;; pass
"type-annotation-test.rkt" ;; pass
"keyword-expansion-test.rkt" ;;pass
"module-tests.rkt" ;; pass
"contract-tests.rkt"
@ -38,6 +39,7 @@
module-tests
fv-tests
contract-tests
keyword-tests
;; this uses dynamic require because the file fails to compile when there's a test failure
(λ () ((dynamic-require special 'typecheck-special-tests))))])
(f))))

84
pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/keyword-expansion-test.rkt Normal file
View File

@ -0,0 +1,84 @@
#lang racket/base
(require "test-utils.rkt"
(rep type-rep)
(types utils kw-types abbrev numeric-tower)
racket/match racket/set
rackunit)
(provide keyword-tests)
(define-syntax-rule (t arg expected)
(begin
(test-equal? (format "~a" '(arg expected))
(kw-convert arg)
expected)))
(define (extract-arrs t)
(match t
[(Function: arrs) (apply set arrs)]
[t t]))
(define-syntax-rule (t-opt ((req-arg ...) (opt-arg ...)) expected)
(let ()
(test-equal? (format "~a" '(opt-convert (->opt req-arg ... (opt-arg ...) result) expected))
(extract-arrs
(opt-convert (->opt req-arg ... (opt-arg ...) result)
(length (list 'req-arg ...))
(length (list 'opt-arg ...))))
(extract-arrs expected))))
(define flag -Boolean)
(define true (-val #t))
(define false (-val #f))
(define result (-val 'result))
(define one (-val 'one))
(define two (-val 'two))
(define three (-val 'three))
(define four (-val 'four))
(define (keyword-tests)
(test-suite "Tests for keyword expansion"
[t (-> result) (-> result)]
[t (-> one result)
(-> one result)]
[t (-> one two three four result)
(-> one two three four result)]
[t (->opt (one) result)
(-> (-opt one) flag result)]
[t (->opt (one two) result)
(-> (-opt one) (-opt two) flag flag result)]
[t (->opt one (two three) result)
(-> one (-opt two) (-opt three) flag flag result)]
[t-opt (() ()) (-> result)]
[t-opt ((one) ())
(-> one result)]
[t-opt (() (one))
(cl->*
(-> one true result)
(-> false false result))]
[t-opt ((one two three four) ())
(-> one two three four result)]
[t-opt (() (one))
(cl->*
(-> one true result)
(-> false false result))]
[t-opt (() (one two))
(cl->*
(-> one two true true result)
(-> one false true false result)
(-> false false false false result))]
[t-opt ((one) (two three))
(cl->*
(-> one two three true true result)
(-> one two false true false result)
(-> one false false false false result))]
))
(define-go keyword-tests)

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

@ -1647,6 +1647,11 @@
[w 'result]
[(x) (add1 "hello")])
(->* (list) Univ (-val 'result) : -true-lfilter)]
[tc-e
(opt-lambda: ((x : Symbol 'a)) x)
#:ret (ret (t:-> -Symbol -Symbol) (-FS -top -bot))
#:expected (ret (t:-> -Symbol -Symbol) (-FS -top -bot))]
)
(test-suite
"check-type tests"