add multi-accumulator for/fold
This commit is contained in:
parent
04b58f9d9f
commit
bdf4c30218
|
@ -17,6 +17,8 @@
|
||||||
error
|
error
|
||||||
define-tuple
|
define-tuple
|
||||||
match-define
|
match-define
|
||||||
|
mk-tuple
|
||||||
|
tuple-select
|
||||||
(for-syntax (all-defined-out)))
|
(for-syntax (all-defined-out)))
|
||||||
|
|
||||||
(require "core-types.rkt")
|
(require "core-types.rkt")
|
||||||
|
@ -164,12 +166,15 @@
|
||||||
(⇒ ν-s #,(make-Branch #'((ss ...) ...)))])
|
(⇒ ν-s #,(make-Branch #'((ss ...) ...)))])
|
||||||
|
|
||||||
|
|
||||||
|
;; (Listof Value) -> Value
|
||||||
|
(define- (mk-tuple es)
|
||||||
|
(#%app- cons- 'tuple es))
|
||||||
|
|
||||||
(define-typed-syntax (tuple e:expr ...) ≫
|
(define-typed-syntax (tuple e:expr ...) ≫
|
||||||
[⊢ e ≫ e- (⇒ : τ)] ...
|
[⊢ e ≫ e- (⇒ : τ)] ...
|
||||||
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions not allowed to have effects"
|
#: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))
|
(define unit : Unit (tuple))
|
||||||
|
|
||||||
|
|
|
@ -25,15 +25,16 @@
|
||||||
|
|
||||||
(define (∀ (X Y Z) (partition/either [xs : (List X)]
|
(define (∀ (X Y Z) (partition/either [xs : (List X)]
|
||||||
[pred : (→fn X (U (Left Y)
|
[pred : (→fn X (U (Left Y)
|
||||||
(Right Z)) #;(Either Y Z))]
|
(Right Z)))]
|
||||||
-> (Tuple (List Y) (List 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])
|
([x xs])
|
||||||
(define y-or-z (pred x))
|
(define y-or-z (pred x))
|
||||||
(match y-or-z
|
(match y-or-z
|
||||||
[(left (bind y Y))
|
[(left (bind y Y))
|
||||||
(tuple (cons y (select 0 acc))
|
(tuple (cons y lefts)
|
||||||
(select 1 acc))]
|
rights)]
|
||||||
[(right (bind z Z))
|
[(right (bind z Z))
|
||||||
(tuple (select 0 acc)
|
(tuple lefts
|
||||||
(cons z (select 1 acc)))])))
|
(cons z rights))])))
|
||||||
|
|
|
@ -15,7 +15,7 @@
|
||||||
(require (only-in "set.rkt" Set ~Set))
|
(require (only-in "set.rkt" Set ~Set))
|
||||||
(require (only-in "hash.rkt" Hash ~Hash))
|
(require (only-in "hash.rkt" Hash ~Hash))
|
||||||
(require (only-in "prim.rkt" Bool + #%datum))
|
(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 "maybe.rkt")
|
||||||
|
|
||||||
(require (postfix-in - (only-in racket/set
|
(require (postfix-in - (only-in racket/set
|
||||||
|
@ -127,36 +127,68 @@
|
||||||
#,body))]))
|
#,body))]))
|
||||||
|
|
||||||
(define-typed-syntax for/fold
|
(define-typed-syntax for/fold
|
||||||
[(for/fold ([acc:id (~optional (~datum :)) τ-acc init])
|
[(for/fold ([acc:id (~optional (~datum :)) τ-acc init] ...+)
|
||||||
(clause:iter-clause
|
(clause:iter-clause
|
||||||
...)
|
...)
|
||||||
e-body ...+) ≫
|
e-body ...+) ≫
|
||||||
[⊢ init ≫ init- (⇐ : τ-acc)]
|
[⊢ init ≫ init- (⇐ : τ-acc)] ...
|
||||||
#:fail-unless (pure? #'init-) "expression must be pure"
|
#:fail-unless (all-pure? #'(init- ...)) "expression must be pure"
|
||||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||||
[[x ≫ x-- : τ] ...
|
#:do [(define num-accs (length (syntax->list #'(τ-acc ...))))]
|
||||||
[acc ≫ acc- : τ-acc] ⊢ (block e-body ...) ≫ e-body-
|
#:with body-ty (if (= 1 num-accs)
|
||||||
(⇐ : τ-acc)
|
(first (syntax->list #'(τ-acc ...)))
|
||||||
(⇒ ν-ep (~effs τ-ep ...))
|
(type-eval #'(Tuple (~@ τ-acc ...))))
|
||||||
(⇒ ν-s (~effs τ-s ...))
|
[[[x ≫ x-- : τ] ...]
|
||||||
(⇒ ν-f (~effs τ-f ...))]
|
[[acc ≫ acc- : τ-acc] ...] ⊢ (block e-body ...) ≫ e-body-
|
||||||
|
(⇐ : body-ty)
|
||||||
|
(⇒ ν-ep (~effs τ-ep ...))
|
||||||
|
(⇒ ν-s (~effs τ-s ...))
|
||||||
|
(⇒ ν-f (~effs τ-f ...))]
|
||||||
-------------------------------------------------------
|
-------------------------------------------------------
|
||||||
[⊢ (for/fold- ([acc- init-])
|
[⊢ (values->tuple #,num-accs
|
||||||
clauses-
|
(for/fold- ([acc- init-] ...)
|
||||||
#,(bind-renames #'([x-- x-] ...) #'e-body-))
|
clauses-
|
||||||
(⇒ : τ-acc)
|
#,(bind-renames #'([x-- x-] ...) #`(tuple->values #,num-accs e-body-))))
|
||||||
|
(⇒ : body-ty)
|
||||||
(⇒ ν-ep (τ-ep ...))
|
(⇒ ν-ep (τ-ep ...))
|
||||||
(⇒ ν-s (τ-s ...))
|
(⇒ ν-s (τ-s ...))
|
||||||
(⇒ ν-f (τ-f ...))]]
|
(⇒ ν-f (τ-f ...))]]
|
||||||
[(for/fold ([acc:id init])
|
[(for/fold (accs ... [acc:id init] more-accs ...)
|
||||||
clauses
|
clauses
|
||||||
e-body ...+) ≫
|
e-body ...+) ≫
|
||||||
[⊢ init ≫ _ (⇒ : τ-acc)]
|
[⊢ init ≫ _ (⇒ : τ-acc)]
|
||||||
---------------------------------------------------
|
---------------------------------------------------
|
||||||
[≻ (for/fold ([acc τ-acc init])
|
[≻ (for/fold (accs ... [acc τ-acc init] more-accs ...)
|
||||||
clauses
|
clauses
|
||||||
e-body ...)]])
|
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 ...)
|
(define-typed-syntax (for/list (clause:iter-clause ...)
|
||||||
e-body ...+) ≫
|
e-body ...+) ≫
|
||||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||||
|
|
|
@ -43,7 +43,7 @@
|
||||||
;; primitives
|
;; primitives
|
||||||
(all-from-out "prim.rkt")
|
(all-from-out "prim.rkt")
|
||||||
;; expressions
|
;; expressions
|
||||||
(all-from-out "core-expressions.rkt")
|
(except-out (all-from-out "core-expressions.rkt") mk-tuple tuple-select)
|
||||||
;; lists
|
;; lists
|
||||||
(all-from-out "list.rkt")
|
(all-from-out "list.rkt")
|
||||||
;; sets
|
;; sets
|
||||||
|
|
Loading…
Reference in New Issue