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

Abstract out function that checks ->* style types

Browse Source
This commit is contained in:
Asumu Takikawa 2014-01-07 17:11:06 -05:00
parent 02dd958a69
commit 40bf3ad243
2 changed files with 33 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -9,7 +9,7 @@
(utils tc-utils)
(env type-name-env)
(rep rep-utils)
(types resolve union)
(types resolve union utils)
(prefix-in t: (types abbrev numeric-tower))
(private parse-type syntax-properties)
racket/match racket/syntax racket/list
@ -348,30 +348,7 @@
;; since this code would generate contracts that accept any number of arguments between
;; 2 and 6, which is wrong.
;; TODO sufficient condition, but may not be necessary
[(and
(> (length arrs) 1)
;; Keyword args, range and rest specs all the same.
(let* ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws)
(list rng rest-spec kws)])
arrs)]
[first-x (first xs)])
(for/and ([x (in-list (rest xs))])
(equal? x first-x)))
;; Positionals are monotonically increasing by at most one.
(let-values ([(_ ok?)
(for/fold ([positionals (arr-dom (first arrs))]
[ok-so-far? #t])
([arr (in-list (rest arrs))])
(match arr
[(arr: dom _ _ _ _)
(define ldom (length dom))
(define lpositionals (length positionals))
(values dom
(and ok-so-far?
(or (= ldom lpositionals)
(= ldom (add1 lpositionals)))
(equal? positionals (take dom lpositionals))))]))])
ok?))
[(has-optional-args? arrs)
(match* ((first arrs) (last arrs))
[((arr: first-dom (Values: (list (Result: rngs (FilterSet: (Top:) (Top:)) (Empty:)) ...)) rst #f kws)
(arr: last-dom _ _ _ _)) ; all but dom is the same for all

31
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/utils.rkt
View File

@ -75,6 +75,36 @@
(provide to-be-abstr)
;; has-optional-args? : (Listof arr) -> Boolean
;; Check if the given arrs meet the necessary conditions to be printed
;; with a ->* constructor or for generating a ->* contract
(define (has-optional-args? arrs)
(and (> (length arrs) 1)
;; No polydots
(for/and ([arr (in-list arrs)])
(match arr [(arr: _ _ _ drest _) (not drest)]))
;; Keyword args, range and rest specs all the same.
(let* ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws)
(list rng rest-spec kws)])
arrs)]
[first-x (first xs)])
(for/and ([x (in-list (rest xs))])
(equal? x first-x)))
;; Positionals are monotonically increasing by at most one.
(let-values ([(_ ok?)
(for/fold ([positionals (arr-dom (first arrs))]
[ok-so-far? #t])
([arr (in-list (rest arrs))])
(match arr
[(arr: dom _ _ _ _)
(define ldom (length dom))
(define lpositionals (length positionals))
(values dom
(and ok-so-far?
(or (= ldom lpositionals)
(= ldom (add1 lpositionals)))
(equal? positionals (take dom lpositionals))))]))])
ok?)))
(provide/cond-contract
[unfold (Mu? . -> . Type/c)]
@ -85,5 +115,6 @@
[fi (Rep? . -> . (listof symbol?))]
[fv/list ((listof Type/c) . -> . (set/c symbol?))]
[current-poly-struct (parameter/c (or/c #f poly?))]
[has-optional-args? (-> (listof arr?) any)]
)