Move TR list special cases to tc-app-list.rkt.
This commit is contained in:
Eric Dobson
Sam Tobin-Hochstadt
parent
7b49ad088a
commit
fcb06ac433
|
|
@ -34,6 +34,9 @@
|
|||
(define-signature tc-app-hetero^
|
||||
([cond-contracted tc/app-hetero (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))]))
|
||||
|
||||
(define-signature tc-app-list^
|
||||
([cond-contracted tc/app-list (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))]))
|
||||
|
||||
(define-signature tc-apply^
|
||||
([cond-contracted tc/apply (syntax? syntax? . -> . tc-results?)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
racket/unsafe/ops
|
||||
(only-in racket/private/class-internal do-make-object)
|
||||
(only-in syntax/location module-name-fixup)
|
||||
(only-in '#%kernel [apply k:apply] [reverse k:reverse])
|
||||
(only-in '#%kernel [apply k:apply])
|
||||
;; end fixme
|
||||
(for-syntax syntax/parse racket/base (utils tc-utils))
|
||||
(private type-annotation)
|
||||
|
|
@ -24,12 +24,12 @@
|
|||
'#%paramz
|
||||
(for-template
|
||||
racket/unsafe/ops racket/fixnum racket/flonum
|
||||
(only-in '#%kernel [apply k:apply] [reverse k:reverse])
|
||||
(only-in '#%kernel [apply k:apply])
|
||||
"internal-forms.rkt" racket/base racket/bool '#%paramz
|
||||
(only-in racket/private/class-internal do-make-object)
|
||||
(only-in syntax/location module-name-fixup)))
|
||||
|
||||
(import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-app-hetero^)
|
||||
(import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-app-hetero^ tc-app-list^)
|
||||
(export tc-app^)
|
||||
|
||||
|
||||
|
|
@ -267,14 +267,12 @@
|
|||
;; syntax tc-results? -> tc-results?
|
||||
(define (tc/app/internal form expected)
|
||||
(or (tc/app-hetero form expected)
|
||||
(tc/app-list form expected)
|
||||
(syntax-parse form
|
||||
#:literals (#%plain-app #%plain-lambda letrec-values quote
|
||||
values apply k:apply not false? list list* call-with-values
|
||||
values apply k:apply not false? list call-with-values
|
||||
do-make-object module-name-fixup cons
|
||||
map andmap ormap reverse k:reverse extend-parameterization
|
||||
vector-ref unsafe-vector-ref unsafe-vector*-ref
|
||||
vector-set! unsafe-vector-set! unsafe-vector*-set!
|
||||
unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set!)
|
||||
extend-parameterization)
|
||||
;; bail out immediately if we have one of these
|
||||
[(#%plain-app rator:special-op . rands) (tc/app/regular form expected)]
|
||||
[(#%plain-app extend-parameterization pmz args ...)
|
||||
|
|
@ -294,7 +292,7 @@
|
|||
;; use the additional but normally ignored first argument to make-sequence
|
||||
;; to provide a better instantiation
|
||||
[(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for))
|
||||
(~and quo ((~literal quote) (i:id ...))) arg:expr)
|
||||
(~and quo (quote (i:id ...))) arg:expr)
|
||||
#:when (andmap type-annotation (syntax->list #'(i ...)))
|
||||
(match (single-value #'op)
|
||||
[(tc-result1: (and t Poly?))
|
||||
|
|
@ -413,46 +411,6 @@
|
|||
(check-do-make-object #'b #'cl #'pos-args #'(names ...) #'(named-args ...))]
|
||||
[(#%plain-app do-make-object args ...)
|
||||
(int-err "unexpected arguments to do-make-object")]
|
||||
[(#%plain-app (~and map-expr (~literal map)) f arg0 arg ...)
|
||||
(match* ((single-value #'arg0) (map single-value (syntax->list #'(arg ...))))
|
||||
;; if the argument is a ListDots
|
||||
[((tc-result1: (ListDots: t0 bound0))
|
||||
(list (tc-result1: (or (and (ListDots: t bound) (app (λ _ #f) var))
|
||||
;; a devious hack - just generate #f so the test below succeeds
|
||||
;; have to explicitly bind `var' since otherwise `var' appears
|
||||
;; on only one side of the or
|
||||
;; NOTE: safe to include these, `map' will error if any list is
|
||||
;; not the same length as all the others
|
||||
(and (Listof: t var) (app (λ _ #f) bound))))
|
||||
...))
|
||||
(=> fail)
|
||||
(unless (for/and ([b bound]) (or (not b) (eq? bound0 b))) (fail))
|
||||
(match (extend-tvars (list bound0)
|
||||
;; just check that the function applies successfully to the element type
|
||||
(tc/funapp #'f #'(arg0 arg ...) (tc-expr #'f) (cons (ret t0) (map ret t)) expected))
|
||||
[(tc-result1: t) (ret (make-ListDots t bound0))]
|
||||
[(tc-results: ts)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Expected one value, but got ~a" (-values ts))])]
|
||||
;; otherwise, if it's not a ListDots, defer to the regular function typechecking
|
||||
[(res0 res)
|
||||
(tc/funapp #'map-expr #'(f arg0 arg ...) (single-value #'map-expr)
|
||||
(list* (tc-expr #'f) res0 res) expected)])]
|
||||
;; ormap/andmap of ... argument
|
||||
[(#%plain-app (~and fun (~or (~literal andmap) (~literal ormap))) f arg)
|
||||
;; check the arguments
|
||||
(match-let* ([arg-ty (single-value #'arg)]
|
||||
[ft (tc-expr #'f)])
|
||||
(match (match arg-ty
|
||||
;; if the argument is a ListDots
|
||||
[(tc-result1: (ListDots: t bound))
|
||||
;; just check that the function applies successfully to the element type
|
||||
(tc/funapp #'f #'(arg) ft (list (ret (substitute Univ bound t))) expected)]
|
||||
;; otherwise ...
|
||||
[_ #f])
|
||||
[(tc-result1: t) (ret (Un (-val #f) t))]
|
||||
;; if it's not a ListDots, defer to the regular function typechecking
|
||||
[_ (tc/funapp #'fun #'(f arg) (single-value #'fun) (list ft arg-ty) expected)]))]
|
||||
;; special case for `delay'
|
||||
[(#%plain-app
|
||||
mp1
|
||||
|
|
@ -461,48 +419,6 @@
|
|||
#:declare mp1 (id-from 'make-promise 'racket/promise)
|
||||
#:declare mp2 (id-from 'make-promise 'racket/promise)
|
||||
(ret (-Promise (tc-expr/t #'e)))]
|
||||
;; special case for `list'
|
||||
[(#%plain-app list . args)
|
||||
(begin
|
||||
;(printf "calling list: ~a ~a\n" (syntax->datum #'args) expected)
|
||||
(match expected
|
||||
[(tc-result1: (Mu: var (Union: (or
|
||||
(list (Pair: elem-ty (F: var)) (Value: '()))
|
||||
(list (Value: '()) (Pair: elem-ty (F: var)))))))
|
||||
;(printf "special case 1 ~a\n" elem-ty)
|
||||
(for ([i (in-list (syntax->list #'args))])
|
||||
(tc-expr/check i (ret elem-ty)))
|
||||
expected]
|
||||
[(tc-result1: (app untuple (? (lambda (ts) (and ts (= (length (syntax->list #'args))
|
||||
(length ts))))
|
||||
ts)))
|
||||
;(printf "special case 2 ~a\n" ts)
|
||||
(for ([ac (in-list (syntax->list #'args))]
|
||||
[exp (in-list ts)])
|
||||
(tc-expr/check ac (ret exp)))
|
||||
expected]
|
||||
[_
|
||||
;(printf "not special case\n")
|
||||
(let ([tys (map tc-expr/t (syntax->list #'args))])
|
||||
(ret (apply -lst* tys)))]))]
|
||||
;; special case for `list*'
|
||||
[(#%plain-app list* . args)
|
||||
(match-let* ([(list tys ... last) (map tc-expr/t (syntax->list #'args))])
|
||||
(ret (foldr make-Pair last tys)))]
|
||||
;; special case for `reverse' to propagate expected type info
|
||||
[(#%plain-app (~or reverse k:reverse) arg)
|
||||
(match expected
|
||||
[(tc-result1: (Listof: _))
|
||||
(tc-expr/check #'arg expected)]
|
||||
[(tc-result1: (List: ts))
|
||||
(tc-expr/check #'arg (ret (-Tuple (reverse ts))))
|
||||
expected]
|
||||
[_
|
||||
(match (single-value #'arg)
|
||||
[(tc-result1: (List: ts))
|
||||
(cond-check-below (ret (-Tuple (reverse ts))) expected)]
|
||||
[arg-ty
|
||||
(tc/funapp #'reverse #'(arg) (single-value #'reverse) (list arg-ty) expected)])])]
|
||||
;; inference for ((lambda
|
||||
[(#%plain-app (#%plain-lambda (x ...) . body) args ...)
|
||||
#:fail-unless (= (length (syntax->list #'(x ...)))
|
||||
|
|
|
|||
107
collects/typed-racket/typecheck/tc-app/tc-app-list.rkt
Normal file
107
collects/typed-racket/typecheck/tc-app/tc-app-list.rkt
Normal file
|
|
@ -0,0 +1,107 @@
|
|||
#lang racket/unit
|
||||
|
||||
|
||||
(require "../../utils/utils.rkt"
|
||||
syntax/parse racket/match
|
||||
(only-in '#%kernel [reverse k:reverse])
|
||||
(typecheck signatures tc-app-helper tc-funapp check-below)
|
||||
(types abbrev utils union substitute)
|
||||
(rep type-rep)
|
||||
(env tvar-env)
|
||||
|
||||
;; fixme - don't need to be bound in this phase - only to make tests work
|
||||
(only-in '#%kernel [reverse k:reverse])
|
||||
;; end fixme
|
||||
|
||||
(for-template
|
||||
racket/base
|
||||
(only-in '#%kernel [reverse k:reverse])))
|
||||
|
||||
|
||||
(import tc-expr^)
|
||||
(export tc-app-list^)
|
||||
|
||||
|
||||
(define (tc/app-list form expected)
|
||||
(syntax-parse form
|
||||
#:literals (#%plain-app
|
||||
reverse k:reverse list list*
|
||||
cons map andmap ormap)
|
||||
[(#%plain-app op:special-op args ...) #f]
|
||||
[(#%plain-app map f arg0 arg ...)
|
||||
(match* ((single-value #'arg0) (map single-value (syntax->list #'(arg ...))))
|
||||
;; if the argument is a ListDots
|
||||
[((tc-result1: (ListDots: t0 bound0))
|
||||
(list (tc-result1: (or (and (ListDots: t bound) (app (λ _ #f) var))
|
||||
;; a devious hack - just generate #f so the test below succeeds
|
||||
;; have to explicitly bind `var' since otherwise `var' appears
|
||||
;; on only one side of the or
|
||||
;; NOTE: safe to include these, `map' will error if any list is
|
||||
;; not the same length as all the others
|
||||
(and (Listof: t var) (app (λ _ #f) bound))))
|
||||
...))
|
||||
(=> fail)
|
||||
(unless (for/and ([b bound]) (or (not b) (eq? bound0 b))) (fail))
|
||||
(match (extend-tvars (list bound0)
|
||||
;; just check that the function applies successfully to the element type
|
||||
(tc/funapp #'f #'(arg0 arg ...) (tc-expr #'f) (cons (ret t0) (map ret t)) expected))
|
||||
[(tc-result1: t) (ret (make-ListDots t bound0))]
|
||||
[(tc-results: ts)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Expected one value, but got ~a" (-values ts))])]
|
||||
;; otherwise, if it's not a ListDots, defer to the regular function typechecking
|
||||
[(res0 res) #f])]
|
||||
;; ormap/andmap of ... argument
|
||||
[(#%plain-app (~or andmap ormap) f arg)
|
||||
;; check the arguments
|
||||
(match-let* ([arg-ty (single-value #'arg)]
|
||||
[ft (tc-expr #'f)])
|
||||
(match (match arg-ty
|
||||
;; if the argument is a ListDots
|
||||
[(tc-result1: (ListDots: t bound))
|
||||
;; just check that the function applies successfully to the element type
|
||||
(tc/funapp #'f #'(arg) ft (list (ret (substitute Univ bound t))) expected)]
|
||||
;; otherwise ...
|
||||
[_ #f])
|
||||
[(tc-result1: t) (ret (Un (-val #f) t))]
|
||||
;; if it's not a ListDots, defer to the regular function typechecking
|
||||
[_ #f]))]
|
||||
;; special case for `list'
|
||||
[(#%plain-app list . args)
|
||||
(match expected
|
||||
[(tc-result1: (Listof: elem-ty))
|
||||
(for ([i (in-list (syntax->list #'args))])
|
||||
(tc-expr/check i (ret elem-ty)))
|
||||
expected]
|
||||
[(tc-result1: (List: (? (lambda (ts) (= (length (syntax->list #'args))
|
||||
(length ts)))
|
||||
ts)))
|
||||
(for ([ac (in-list (syntax->list #'args))]
|
||||
[exp (in-list ts)])
|
||||
(tc-expr/check ac (ret exp)))
|
||||
expected]
|
||||
[_
|
||||
(let ([tys (map tc-expr/t (syntax->list #'args))])
|
||||
(ret (apply -lst* tys)))])]
|
||||
;; special case for `list*'
|
||||
[(#%plain-app list* . args)
|
||||
(match-let* ([(list tys ... last) (map tc-expr/t (syntax->list #'args))])
|
||||
(ret (foldr -pair last tys)))]
|
||||
;; special case for `reverse' to propagate expected type info
|
||||
[(#%plain-app (~or reverse k:reverse) arg)
|
||||
(match expected
|
||||
[(tc-result1: (Listof: _))
|
||||
(tc-expr/check #'arg expected)]
|
||||
[(tc-result1: (List: ts))
|
||||
(tc-expr/check #'arg (ret (-Tuple (reverse ts))))
|
||||
expected]
|
||||
[_
|
||||
(match (single-value #'arg)
|
||||
[(tc-result1: (List: ts))
|
||||
(cond-check-below (ret (-Tuple (reverse ts))) expected)]
|
||||
[arg-ty
|
||||
(tc/funapp #'reverse #'(arg) (single-value #'reverse) (list arg-ty) expected)])])]
|
||||
[_ #f]))
|
||||
|
||||
|
||||
|
||||
|
|
@ -6,7 +6,9 @@
|
|||
provide-signature-elements
|
||||
define-values/invoke-unit/infer link)
|
||||
"signatures.rkt"
|
||||
"tc-app/tc-app-hetero.rkt" "signatures.rkt"
|
||||
"tc-app/tc-app-hetero.rkt"
|
||||
"tc-app/tc-app-list.rkt"
|
||||
"signatures.rkt"
|
||||
"tc-if.rkt" "tc-lambda-unit.rkt" "tc-app.rkt"
|
||||
"tc-let-unit.rkt" "tc-apply.rkt"
|
||||
"tc-expr-unit.rkt" "check-subforms-unit.rkt")
|
||||
|
|
@ -15,4 +17,4 @@
|
|||
|
||||
(define-values/invoke-unit/infer
|
||||
(link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@ tc-apply@
|
||||
tc-app-hetero@))
|
||||
tc-app-hetero@ tc-app-list@))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user