add multi-accumulator for/fold

racket/typed/core-expressions.rkt

@@ -17,6 +17,8 @@
          error
          define-tuple
          match-define
+         mk-tuple
+         tuple-select
          (for-syntax (all-defined-out)))
 
 (require "core-types.rkt")
@@ -164,12 +166,15 @@
      (⇒ ν-s #,(make-Branch #'((ss ...) ...)))])
 
 
+;; (Listof Value) -> Value
+(define- (mk-tuple es)
+  (#%app- cons- 'tuple es))
 
 (define-typed-syntax (tuple e:expr ...) ≫
   [⊢ e ≫ e- (⇒ : τ)] ...
   #:fail-unless (stx-andmap pure? #'(e- ...)) "expressions not allowed to have effects"
   -----------------------
-  [⊢ (#%app- list- 'tuple e- ...) (⇒ : (Tuple τ ...))])
+  [⊢ (#%app- mk-tuple (#%app- list- e- ...)) (⇒ : (Tuple τ ...))])
 
 (define unit : Unit (tuple))
 

racket/typed/either.rkt

@@ -25,15 +25,16 @@
 
 (define (∀ (X Y Z) (partition/either [xs : (List X)]
                                      [pred : (→fn X (U (Left Y)
-                                                       (Right Z)) #;(Either Y Z))]
+                                                       (Right Z)))]
                                      -> (Tuple (List Y) (List Z))))
-  (for/fold ([acc (Tuple (List Y) (List Z)) (tuple (list) (list))])
+  (for/fold ([lefts (List Y) (list)]
+             [rights (List Z) (list)])
             ([x xs])
     (define y-or-z (pred x))
     (match y-or-z
       [(left (bind y Y))
-       (tuple (cons y (select 0 acc))
-              (select 1 acc))]
+       (tuple (cons y lefts)
+              rights)]
       [(right (bind z Z))
-       (tuple (select 0 acc)
-              (cons z (select 1 acc)))])))
+       (tuple lefts
+              (cons z rights))])))

racket/typed/for-loops.rkt

@@ -15,7 +15,7 @@
 (require (only-in "set.rkt" Set ~Set))
 (require (only-in "hash.rkt" Hash ~Hash))
 (require (only-in "prim.rkt" Bool + #%datum))
-(require (only-in "core-expressions.rkt" let unit))
+(require (only-in "core-expressions.rkt" let unit tuple-select mk-tuple))
 (require "maybe.rkt")
 
 (require (postfix-in - (only-in racket/set
@@ -127,36 +127,68 @@
              #,body))]))
 
 (define-typed-syntax for/fold
-  [(for/fold ([acc:id (~optional (~datum :)) τ-acc init])
+  [(for/fold ([acc:id (~optional (~datum :)) τ-acc init] ...+)
              (clause:iter-clause
               ...)
      e-body ...+) ≫
-  [⊢ init ≫ init- (⇐ : τ-acc)]
-  #:fail-unless (pure? #'init-) "expression must be pure"
+  [⊢ init ≫ init- (⇐ : τ-acc)] ...
+  #:fail-unless (all-pure? #'(init- ...)) "expression must be pure"
   #:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
-  [[x ≫ x-- : τ] ...
-   [acc ≫ acc- : τ-acc] ⊢ (block e-body ...) ≫ e-body-
-                           (⇐ : τ-acc)
-                           (⇒ ν-ep (~effs τ-ep ...))
-                           (⇒ ν-s (~effs τ-s ...))
-                           (⇒ ν-f (~effs τ-f ...))]
+  #:do [(define num-accs (length (syntax->list #'(τ-acc ...))))]
+  #:with body-ty (if (= 1 num-accs)
+                     (first (syntax->list #'(τ-acc ...)))
+                     (type-eval #'(Tuple (~@ τ-acc ...))))
+  [[[x ≫ x-- : τ] ...]
+   [[acc ≫ acc- : τ-acc] ...] ⊢ (block e-body ...) ≫ e-body-
+                               (⇐ : body-ty)
+                               (⇒ ν-ep (~effs τ-ep ...))
+                               (⇒ ν-s (~effs τ-s ...))
+                               (⇒ ν-f (~effs τ-f ...))]
   -------------------------------------------------------
-  [⊢ (for/fold- ([acc- init-])
-                clauses-
-                #,(bind-renames #'([x-- x-] ...) #'e-body-))
-     (⇒ : τ-acc)
+  [⊢ (values->tuple #,num-accs
+       (for/fold- ([acc- init-] ...)
+         clauses-
+         #,(bind-renames #'([x-- x-] ...) #`(tuple->values #,num-accs e-body-))))
+     (⇒ : body-ty)
      (⇒ ν-ep (τ-ep ...))
      (⇒ ν-s (τ-s ...))
      (⇒ ν-f (τ-f ...))]]
-  [(for/fold ([acc:id init])
+  [(for/fold (accs ... [acc:id init] more-accs ...)
              clauses
      e-body ...+) ≫
    [⊢ init ≫ _ (⇒ : τ-acc)]
    ---------------------------------------------------
-   [≻ (for/fold ([acc τ-acc init])
+   [≻ (for/fold (accs ... [acc τ-acc init] more-accs ...)
                 clauses
         e-body ...)]])
 
+(define-syntax-parser tuple->values
+  [(_ n:nat e:expr)
+   (define arity (syntax-e #'n))
+   (cond
+     [(= 1 arity)
+      #'e]
+     [else
+      (define/with-syntax tmp (generate-temporary 'tup))
+      (define projections
+        (for/list ([i (in-range arity)])
+          #`(#%app- tuple-select #,i tmp)))
+      #`(let- ([tmp e])
+          (#%app- values- #,@projections))])])
+
+#;(tuple->values 1 (tuple 0))
+
+(define-syntax-parser values->tuple
+  [(_ n:nat e:expr)
+   (define arity (syntax-e #'n))
+   (cond
+     [(= 1 arity)
+      #'e]
+     [else
+      (define/with-syntax (tmp ...) (generate-temporaries (make-list arity 'values->tuple)))
+      #`(let-values- ([(tmp ...) e])
+          (#%app- mk-tuple (#%app- list- tmp ...)))])])
+
 (define-typed-syntax (for/list (clause:iter-clause ...)
                        e-body ...+) ≫
   #:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))

racket/typed/roles.rkt

@@ -43,7 +43,7 @@
          ;; primitives
          (all-from-out "prim.rkt")
          ;; expressions
-         (all-from-out "core-expressions.rkt")
+         (except-out (all-from-out "core-expressions.rkt") mk-tuple tuple-select)
          ;; lists
          (all-from-out "list.rkt")
          ;; sets