Skip to content

Commit 1aa6c49

Browse files
endobsonendobson
committed
Correct subst/dots on list-dots and values-dots.
1 parent c2fa9d2 commit 1aa6c49

File tree

4 files changed

+29
-24
lines changed

4 files changed

+29
-24
lines changed

‎pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt

Lines changed: 0 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -68,12 +68,6 @@
6868

6969
(define (-opt t) (Un (-val #f) t))
7070

71-
(define (-Tuple l)
72-
(-Tuple* l -Null))
73-
74-
(define (-Tuple* l b)
75-
(foldr -pair b l))
76-
7771
;; Convenient constructor for Values
7872
;; (wraps arg types with Result)
7973
(define/cond-contract (-values args)

‎pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -59,10 +59,14 @@
5959
;; Void is needed for Params
6060
(define/decl -Void (make-Base 'Void #'void? void? #f))
6161

62-
;; -lst* Type is needed by substitute for ListDots
62+
;; -Tuple Type is needed by substitute for ListDots
6363
(define -pair make-Pair)
6464
(define (-lst* #:tail [tail -Null] . args)
6565
(for/fold ([tl tail]) ([a (in-list (reverse args))]) (-pair a tl)))
66+
(define (-Tuple l)
67+
(-Tuple* l -Null))
68+
(define (-Tuple* l b)
69+
(foldr -pair b l))
6670

6771
;; Simple union type constructor, does not check for overlaps
6872
;; Normalizes representation by sorting types.

‎pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/substitute.rkt

Lines changed: 12 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44
racket/match racket/set
55
racket/lazy-require
66
(contract-req)
7-
(only-in (types base-abbrev) -lst* -result)
7+
(only-in (types base-abbrev) -Tuple* -lst -Null -result ManyUniv)
88
(rep type-rep rep-utils)
99
(utils tc-utils)
1010
(rep free-variance)
@@ -99,19 +99,21 @@
9999
(if (eq? name dbound)
100100
;; We need to recur first, just to expand out any dotted usages of this.
101101
(let ([expanded (sb dty)])
102-
(for/fold ([t (make-Value null)])
102+
(for/fold ([t (if rimage (-lst rimage) -Null)])
103103
([img (in-list (reverse images))])
104104
(make-Pair (substitute img name expanded) t)))
105105
(make-ListDots (sb dty) dbound))]
106106
[#:ValuesDots types dty dbound
107107
(if (eq? name dbound)
108-
(make-Values
109-
(append
110-
(map sb types)
111-
;; We need to recur first, just to expand out any dotted usages of this.
112-
(let ([expanded (sb dty)])
113-
(for/list ([img (in-list images)])
114-
(-result (substitute img name expanded))))))
108+
(if rimage
109+
ManyUniv
110+
(make-Values
111+
(append
112+
(map sb types)
113+
;; We need to recur first, just to expand out any dotted usages of this.
114+
(let ([expanded (sb dty)])
115+
(for/list ([img (in-list images)])
116+
(-result (substitute img name expanded)))))))
115117
(make-ValuesDots (map sb types) (sb dty) dbound))]
116118
[#:arr dom rng rest drest kws
117119
(if (and (pair? drest)
@@ -148,9 +150,8 @@
148150
(sb dty)
149151
(if (eq? name dbound) image-bound dbound)))]
150152
[#:ListDots dty dbound
151-
(apply -lst*
153+
(-Tuple*
152154
(if (eq? name dbound) pre-image null)
153-
#:tail
154155
(make-ListDots (sb dty)
155156
(if (eq? name dbound) image-bound dbound)))]
156157
[#:F name*

‎pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/subst-tests.rkt

Lines changed: 12 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -10,14 +10,20 @@
1010
(define-syntax-rule (s img var tgt result)
1111
(test-eq? (format "~a" '(img tgt)) (substitute img 'var tgt) result))
1212

13+
14+
(define-syntax-rule (s* imgs rest var tgt result)
15+
(test-eq? (format "~a" '(img tgt)) (substitute-dots (list . imgs) rest 'var tgt) result))
16+
1317
(define-syntax-rule (s... imgs var tgt result)
1418
(test-eq? (format "~a" '(img tgt)) (substitute-dots (list . imgs) #f 'var tgt) result))
1519

1620
(define tests
1721
(test-suite "Tests for substitution"
18-
(s -Number a (-v a) -Number)
19-
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots null -Number (-v a) 'a))) (-Number -Boolean . -> . -Number))
20-
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v a) 'a))) (-String -Number -Boolean . -> . -Number))
21-
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'a))) (-String (-v b) (-v b) . -> . -Number))
22-
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b)))
23-
(make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b))))))
22+
(s -Number a (-v a) -Number)
23+
(s* (-Symbol -String) #f a (make-ListDots (-v a) 'a) (-lst* -Symbol -String))
24+
(s* (-Symbol -String) Univ a (make-ListDots (-v a) 'a) (-lst* -Symbol -String #:tail (-lst Univ)))
25+
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots null -Number (-v a) 'a))) (-Number -Boolean . -> . -Number))
26+
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v a) 'a))) (-String -Number -Boolean . -> . -Number))
27+
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'a))) (-String (-v b) (-v b) . -> . -Number))
28+
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b)))
29+
(make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b))))))

0 commit comments

Comments
 (0)