initial rest cycle support

Author: Andrew Kent

typed-racket-lib/typed-racket/base-env/base-env.rkt

@@ -923,21 +923,9 @@
 [hash-eqv? (-> -HashTableTop B)]
 [hash-equal? (-> -HashTableTop B)]
 [hash-weak? (asym-pred -HashTableTop B (-PS (-is-type 0 -Weak-HashTableTop) (-not-type 0 -Weak-HashTableTop)))]
-[hash (-poly (a b) (cl->* (-> (-Immutable-HT a b))
-                          (a b . -> . (-Immutable-HT a b))
-                          (a b a b . -> . (-Immutable-HT a b))
-                          (a b a b a b . -> . (-Immutable-HT a b))
-                          (a b a b a b a b . -> . (-Immutable-HT a b))))]
-[hasheqv (-poly (a b) (cl->* (-> (-Immutable-HT a b))
-                             (a b . -> . (-Immutable-HT a b))
-                             (a b a b . -> . (-Immutable-HT a b))
-                             (a b a b a b . -> . (-Immutable-HT a b))
-                             (a b a b a b a b . -> . (-Immutable-HT a b))))]
-[hasheq (-poly (a b) (cl->* (-> (-Immutable-HT a b))
-                            (a b . -> . (-Immutable-HT a b))
-                            (a b a b . -> . (-Immutable-HT a b))
-                            (a b a b a b . -> . (-Immutable-HT a b))
-                            (a b a b a b a b . -> . (-Immutable-HT a b))))]
+[hash (-poly (a b) (->* (list) (make-Rest (list a b)) (-Immutable-HT a b)))]
+[hasheqv (-poly (a b) (->* (list) (make-Rest (list a b)) (-Immutable-HT a b)))]
+[hasheq (-poly (a b) (->* (list) (make-Rest (list a b)) (-Immutable-HT a b)))]
 [make-hash (-poly (a b) (->opt [(-lst (-pair a b))] (-Mutable-HT a b)))]
 [make-hasheq (-poly (a b) (->opt [(-lst (-pair a b))] (-Mutable-HT a b)))]
 [make-hasheqv (-poly (a b) (->opt [(-lst (-pair a b))] (-Mutable-HT a b)))]

typed-racket-lib/typed-racket/env/init-envs.rkt

@@ -324,6 +324,8 @@
        ,(and rest (type->sexp rest))
        (list ,@(map type->sexp kws))
        ,(type->sexp rng))]
+    [(Rest: tys )
+     `(make-Rest (list ,@(map type->sexp tys)))]
     [(RestDots: ty db)
      `(make-RestDots ,(type->sexp ty)
                      (quote ,db))]

typed-racket-lib/typed-racket/infer/infer-unit.rkt

@@ -22,6 +22,7 @@
          "signatures.rkt" "fail.rkt"
          "promote-demote.rkt"
          racket/match
+         ;racket/trace
          (contract-req)
          (for-syntax
            racket/base
@@ -175,20 +176,24 @@
 ;; of them.
 (struct seq (types end) #:transparent)
 (struct null-end () #:transparent)
-(struct uniform-end (type) #:transparent)
+(define -null-end (null-end))
+;; cycle is the pattern of the rest of the seq,
+;; e.g. a rest argument of Num would just be (list Num)
+;;      a rest arg of (Num Str) would be (list Num Str)
+(struct cycle-end (cycle) #:transparent)
 (struct dotted-end (type bound) #:transparent)
 
 (define (Values->seq v)
   (match v
-    [(Values: ts) (seq ts (null-end))]
+    [(Values: ts) (seq ts -null-end)]
     [(ValuesDots: ts dty dbound) (seq ts (dotted-end (-result dty) dbound))]
     [_ #f]))
 
 
 (define (List->end v)
   (match v
-    [(== -Null) (null-end)]
-    [(Listof: t) (uniform-end t)]
+    [(== -Null) -null-end]
+    [(Listof: t) (cycle-end (list t))]
     [(ListDots: t dbound) (dotted-end t dbound)]
     [_ #f]))
 
@@ -256,19 +261,27 @@
     [((seq ss (null-end))
       (seq ts (null-end)))
       (cgen/list context ss ts)]
-    ;; One is null-end the other is uniform-end
+    ;; One is null-end the other is cycle-end
     [((seq ss (null-end))
-      (seq ts (uniform-end t-rest)))
-     (cgen/list context ss (list-extend ss ts t-rest))]
-    [((seq ss (uniform-end s-rest))
+      (seq ts (cycle-end t-rest)))
+     (define ss-len (length ss))
+     (define ts-len (length ts))
+     #:return-unless (<= ts-len ss-len) #f
+     (define fewer-args (- ss-len ts-len))
+     (define cycle-len (length t-rest))
+     #:return-unless (eqv? 0 (remainder fewer-args cycle-len)) #f
+     (define repetitions (quotient fewer-args cycle-len))
+     (define new-ts (append ts (repeat-list t-rest repetitions)))
+     (cgen/list context ss new-ts)]
+    [((seq ss (cycle-end _))
       (seq ts (null-end)))
      #f]
-    ;; Both are uniform-end
-    [((seq ss (uniform-end s-rest))
-      (seq ts (uniform-end t-rest)))
-     (cgen/list context
-                (cons s-rest ss)
-                (cons t-rest (list-extend ss ts t-rest)))]
+    ;; Both are cycle-end
+    [((seq ss (cycle-end s-rest))
+      (seq ts (and t-end (cycle-end t-rest))))
+     (cgen/seq context
+               (seq (append s-rest ss) -null-end)
+               (seq (append t-rest ts) t-end))]
     ;; dotted below, nothing above
     [((seq ss (dotted-end dty dbound))
       (seq ts (null-end)))
@@ -326,27 +339,37 @@
           (% move-dotted-rest-to-dmap (cgen (context-add-var context dbound*) s-dty t-dty) dbound* dbound)))]
 
     ;; * <: ...
-    [((seq ss (uniform-end s-rest))
+    [((seq ss (cycle-end (list s-rest-ty)))
       (seq ts (dotted-end t-dty dbound)))
      #:return-unless (inferable-index? context dbound)
      #f
      #:return-unless (<= (length ts) (length ss))
      #f
      (define new-bound (gensym dbound))
-     (define-values (vars new-tys) (generate-dbound-prefix dbound t-dty (- (length ss) (length ts))
-                                                           new-bound))
+     (define-values (vars new-tys)
+       (generate-dbound-prefix dbound t-dty (- (length ss) (length ts))
+                               new-bound))
      (define-values (ss-front ss-back) (split-at ss (length ts)))
      (% cset-meet
         (cgen/list context ss-front ts)
         (% move-vars+rest-to-dmap
            (% cset-meet
-              (cgen/list (context-add context #:bounds (list new-bound) #:vars vars #:indices (list new-bound))
-                         ss-back new-tys)
-              (cgen (context-add-var context dbound) s-rest t-dty))
+              (cgen/list (context-add context
+                                      #:bounds (list new-bound)
+                                      #:vars vars
+                                      #:indices (list new-bound))
+                         ss-back
+                         new-tys)
+              (cgen (context-add-var context dbound) s-rest-ty t-dty))
            vars dbound #:exact #t))]
+    ;; TODO figure out how above code could be modified to support
+    ;; cycle-end w/ a cycle of len > 1
+    [((seq ss (cycle-end _))
+      (seq ts (dotted-end _ _)))
+     #f]
 
     [((seq ss (dotted-end s-dty dbound))
-      (seq ts (uniform-end t-rest)))
+      (seq ts (cycle-end (list t-rest-ty))))
      (cond
        [(inferable-index? context dbound)
         (define new-bound (gensym dbound))
@@ -356,16 +379,21 @@
         (% cset-meet
            (cgen/list context ss (if (positive? length-delta)
                                      (drop-right ts length-delta)
-                                     (list-extend ss ts t-rest)))
+                                     (list-extend ss ts t-rest-ty)))
            (% move-vars+rest-to-dmap
               (% cset-meet
                  (cgen/list (context-add context #:bounds (list new-bound) #:vars vars #:indices (list new-bound))
                             new-tys (take-right ts (max 0 length-delta)))
-                 (cgen (context-add-var context dbound) s-dty t-rest))
+                 (cgen (context-add-var context dbound) s-dty t-rest-ty))
               vars dbound))]
        [else
         (extend-tvars (list dbound)
-          (cgen/seq (context-add context #:bounds (list dbound)) (seq ss (uniform-end s-dty)) t-seq))])]))
+                      (cgen/seq (context-add context #:bounds (list dbound))
+                                (seq ss (cycle-end (list s-dty)))
+                                t-seq))])]
+    [((seq ts (dotted-end _ _))
+      (seq ss (cycle-end _)))
+     #f]))
 
 (define/cond-contract (cgen/arrow context s-arr t-arr)
   (context? Arrow? Arrow? . -> . (or/c #f cset?))
@@ -374,10 +402,10 @@
       (Arrow: ts t-rest t-kws t))
      (define (rest->end rest)
        (match rest
-         [(? Type?) (uniform-end rest)]
+         [(Rest: rst-ts) (cycle-end rst-ts)]
          [(RestDots: ty dbound)
           (dotted-end ty dbound)]
-         [_ (null-end)]))
+         [_ -null-end]))
 
      (define s-seq (seq ss (rest->end s-rest)))
      (define t-seq (seq ts (rest->end t-rest)))
@@ -947,9 +975,16 @@
 ;; like infer, but T-var is the vararg type:
 (define (infer/vararg X Y S T T-var R [expected #f]
                       #:objs [objs '()])
-  (define new-T (if T-var (list-extend S T T-var) T))
   (and ((length S) . >= . (length T))
-       (infer X Y S new-T R expected #:objs objs)))
+       (let* ([fewer-ts (- (length S) (length T))]
+              [new-T (match T-var
+                       [(? Type? var-t) (list-extend S T var-t)]
+                       [(Rest: rst-ts)
+                        #:when (eqv? 0 (remainder fewer-ts (length rst-ts)))
+                        (append T (repeat-list rst-ts
+                                               (quotient fewer-ts (length rst-ts))))]
+                       [_ T])])
+         (infer X Y S new-T R expected #:objs objs))))
 
 ;; like infer, but dotted-var is the bound on the ...
 ;; and T-dotted is the repeated type
@@ -988,6 +1023,6 @@
 ;(trace substs-gen)
 ;(trace cgen)
 ;(trace cgen/list)
-;(trace cgen/arr)
+;(trace cgen/arrow)
 ;(trace cgen/seq)
 

typed-racket-lib/typed-racket/infer/promote-demote.rkt

@@ -36,21 +36,21 @@
   ;; Returns the changed arr or #f if there is no arr above it
   (define (arr-change arr)
     (match arr
-      [(Arrow: dom rest kws rng)
+      [(Arrow: dom rst kws rng)
        (cond
          [(apply V-in? V (get-propsets rng))
           #f]
-         [(and (RestDots? rest)
-               (memq (RestDots-nm rest) V))
+         [(and (RestDots? rst)
+               (memq (RestDots-nm rst) V))
           (make-Arrow
            (map contra dom)
-           (contra (RestDots-ty rest))
+           (contra (RestDots-ty rst))
            (map contra kws)
            (co rng))]
          [else
           (make-Arrow
            (map contra dom)
-           (and rest (contra rest))
+           (and rst (contra rst))
            (map contra kws)
            (co rng))])]))
   (match cur

typed-racket-lib/typed-racket/infer/signatures.rkt

@@ -50,7 +50,7 @@
                                    ;; domain
                                    (listof Type?)
                                    ;; rest
-                                   (or/c #f Type?)
+                                   (or/c #f Type? Rest?)
                                    ;; range
                                    (or/c #f Values/c ValuesDots?))
                                   ;; [optional] expected type

typed-racket-lib/typed-racket/private/parse-type.rkt

@@ -287,7 +287,7 @@
            ;; does not need to be delayed since there's no parsing done
            #:attr result #'t))
 
-(define-splicing-syntax-class ->*-rest
+(define-splicing-syntax-class optional->*-rest
   #:description "rest argument type for ->*"
   #:attributes (type)
   (pattern (~optional (~seq #:rest type:non-keyword-ty))))
@@ -958,10 +958,32 @@
               (parse-type #'rng)
               : (-PS (attribute latent.positive) (attribute latent.negative))
               : (attribute latent.object)))]
+      ;; like ->* below but w/ a #:rest-pat present
       [(:->*^ (~var mand (->*-args #t))
               (~optional (~var opt (->*-args #f))
                          #:defaults ([opt.doms null] [opt.kws null]))
-              rest:->*-rest
+              #:rest-pat (hrest-types-stx:non-keyword-ty ...)
+              rng)
+       (with-arity (length (attribute mand.doms))
+         (define doms (for/list ([d (attribute mand.doms)])
+                        (parse-type d)))
+         (define opt-doms (for/list ([d (attribute opt.doms)])
+                            (parse-type d)))
+         (define hrest-tys (stx-map parse-type #'(hrest-types-stx ...)))
+         (cond
+           [(< (length hrest-tys) 2)
+            (parse-error
+             "heterogeneous rest specifications must include at least 2 types"
+             "given" (syntax->datum #'(hrest-types-stx ...)))]
+           [else
+            (opt-fn doms opt-doms (parse-values-type #'rng)
+                    #:rest (make-Rest hrest-tys)
+                    #:kws (map force (append (attribute mand.kws)
+                                             (attribute opt.kws))))]))]
+      [(:->*^ (~var mand (->*-args #t))
+              (~optional (~var opt (->*-args #f))
+                         #:defaults ([opt.doms null] [opt.kws null]))
+              rest:optional->*-rest
               rng)
        (with-arity (length (attribute mand.doms))
          (define doms (for/list ([d (attribute mand.doms)])
@@ -970,7 +992,7 @@
                             (parse-type d)))
          (opt-fn doms opt-doms (parse-values-type #'rng)
                  #:rest (and (attribute rest.type)
-                             (parse-type (attribute rest.type)))
+                             (make-Rest (list (parse-type (attribute rest.type)))))
                  #:kws (map force (append (attribute mand.kws)
                                           (attribute opt.kws)))))]
       [:->^

typed-racket-lib/typed-racket/private/type-contract.rkt

@@ -732,6 +732,8 @@
         (channel/sc (t->sc t))]
        [(Evt: t)
         (evt/sc (t->sc t))]
+       [(Rest: (list rst-t)) (listof/sc (t->sc rst-t))]
+       [(? Rest? rst) (t->sc (Rest->Mu rst))]
        [(? Prop? rep) (prop->sc rep)]
        [_
         (fail #:reason "contract generation not supported for this type")]))))
@@ -808,7 +810,7 @@
              (values (map conv mand-kws)
                      (map conv opt-kws))))
          (define range (map t->sc rngs))
-         (define rest (and rst (listof/sc (t->sc/neg rst))))
+         (define rest (and rst (t->sc/neg rst)))
          (function/sc (from-typed? typed-side) (process-dom mand-args) opt-args mand-kws opt-kws rest range))
        (handle-arrow-range first-arrow convert-arrow)]
       [else
@@ -823,7 +825,7 @@
                                      " with optional keyword arguments")))
                 (if case->
                   (arr/sc (process-dom (map t->sc/neg dom))
-                          (and rst (listof/sc (t->sc/neg rst)))
+                          (and rst (t->sc/neg rst))
                           (map t->sc rngs))
                   (function/sc
                     (from-typed? typed-side)
@@ -832,7 +834,7 @@
                     (map conv mand-kws)
                     (map conv opt-kws)
                     (match rst
-                      [(? Type?) (listof/sc (t->sc/neg rst))]
+                      [(? Rest?) (t->sc/neg rst)]
                       [(RestDots: dty dbound)
                        (listof/sc
                         (t->sc/neg dty

typed-racket-lib/typed-racket/rep/type-rep.rkt

@@ -508,6 +508,19 @@
       (= (length kws) 1)
       (equal? kws (sort kws Keyword<?))))
 
+;; a Rest argument description
+;; tys: the cycle describing the rest args
+;; e.g.
+;; tys = (list Number) means all provided rest args
+;;        must all be a Number (see `+')
+;; tys = (list A B) means the rest arguments must be
+;;       of even cardinality, and must be an A followed
+;;       by a B repeated (e.g. A B A B A B)
+;; etc
+(def-rep Rest ([tys (cons/c Type? (listof Type?))])
+  [#:frees (f) (combine-frees (map f tys))]
+  [#:fmap (f) (make-Rest (map f tys))]
+  [#:for-each (f) (for-each f tys)])
 
 (def-rep RestDots ([ty Type?]
                    [nm (or/c natural-number/c symbol?)])
@@ -525,7 +538,7 @@
 
 
 (def-rep Arrow ([dom (listof Type?)]
-                [rst (or/c #f Type? RestDots?)]
+                [rst (or/c #f Rest? RestDots?)]
                 [kws (and/c (listof Keyword?) keyword-sorted/c)]
                 [rng SomeValues?])
   [#:frees (f)

typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt

@@ -56,12 +56,12 @@
          (tc/funapp #'here #'(here) t (list (ret arg1)) #f)]
         [(Fun: (list _ ...
                      (Arrow: (list)
-                             (? Type? rst)
+                             (Rest: (list rst-t))
                              (list (Keyword: _ _ #f) ...)
                              _ )
                      _ ...))
-         #:when (subtype prop-type rst)
-         (tc/funapp #'here #'(here) t (list (ret rst)) #f)]
+         #:when (subtype prop-type rst-t)
+         (tc/funapp #'here #'(here) t (list (ret rst-t)) #f)]
         [(? resolvable? t)
          (loop (resolve t))]
         [(or (Poly: ns _) (PolyDots: (list ns ... _) _))