2019-04-30 21:42:03 +00:00
|
|
|
|
#lang turnstile
|
|
|
|
|
|
2019-05-13 19:35:38 +00:00
|
|
|
|
(provide for/fold
|
2019-05-21 20:56:53 +00:00
|
|
|
|
for
|
2019-05-13 19:35:38 +00:00
|
|
|
|
for/list
|
|
|
|
|
for/set
|
2019-05-21 20:56:53 +00:00
|
|
|
|
for/sum
|
2020-10-21 15:05:46 +00:00
|
|
|
|
for/first
|
|
|
|
|
in-hash-values
|
|
|
|
|
in-hash-keys)
|
2019-04-30 21:42:03 +00:00
|
|
|
|
|
|
|
|
|
(require "core-types.rkt")
|
|
|
|
|
(require "sequence.rkt")
|
|
|
|
|
(require (only-in "list.rkt" List ~List))
|
|
|
|
|
(require (only-in "set.rkt" Set ~Set))
|
|
|
|
|
(require (only-in "hash.rkt" Hash ~Hash))
|
2019-05-13 19:35:38 +00:00
|
|
|
|
(require (only-in "prim.rkt" Bool + #%datum))
|
2020-10-22 20:46:33 +00:00
|
|
|
|
(require (only-in "core-expressions.rkt" let unit tuple-select mk-tuple))
|
2019-05-21 20:56:53 +00:00
|
|
|
|
(require "maybe.rkt")
|
2019-05-13 19:35:38 +00:00
|
|
|
|
|
|
|
|
|
(require (postfix-in - (only-in racket/set
|
|
|
|
|
for/set
|
|
|
|
|
in-set)))
|
2019-04-30 21:42:03 +00:00
|
|
|
|
|
|
|
|
|
(begin-for-syntax
|
|
|
|
|
(define-splicing-syntax-class iter-clause
|
|
|
|
|
#:attributes (parend)
|
|
|
|
|
#:datum-literals (:)
|
|
|
|
|
(pattern [x:id seq:expr]
|
|
|
|
|
#:attr parend #'[x seq])
|
|
|
|
|
(pattern [x:id : τ:type seq:expr]
|
|
|
|
|
#:attr parend #'[x : τ seq])
|
|
|
|
|
(pattern [(k:id v:id) hash-seq:expr]
|
|
|
|
|
#:attr parend #'[(k v) hash-seq])
|
|
|
|
|
(pattern (~seq #:when pred:expr)
|
|
|
|
|
#:attr parend #'(#:when pred))
|
|
|
|
|
(pattern (~seq #:unless pred:expr)
|
|
|
|
|
#:attr parend #'(#:unless pred))
|
|
|
|
|
(pattern (~seq #:break pred:expr)
|
|
|
|
|
#:attr parend #'(#:break pred))))
|
|
|
|
|
|
2019-05-13 15:56:57 +00:00
|
|
|
|
;; a Binding is a (SyntaxList Id Id Type), i.e. #'(x x- τ-x)
|
2019-04-30 21:42:03 +00:00
|
|
|
|
(begin-for-syntax
|
|
|
|
|
(struct loop-clause (exp bindings) #:transparent)
|
|
|
|
|
(struct directive (kw exp) #:transparent))
|
|
|
|
|
|
|
|
|
|
|
2019-05-13 15:56:57 +00:00
|
|
|
|
;; (SyntaxListOf LoopClause) -> (Syntax LoopClause- (Binding ...))
|
2019-04-30 21:42:03 +00:00
|
|
|
|
(define-for-syntax (analyze-for-clauses clauses)
|
|
|
|
|
(define-values (br binds)
|
|
|
|
|
(for/fold ([body-rev '()]
|
|
|
|
|
[bindings '()])
|
|
|
|
|
([clause (in-syntax clauses)])
|
2019-05-13 15:56:57 +00:00
|
|
|
|
(match (analyze-for-clause clause bindings)
|
2019-04-30 21:42:03 +00:00
|
|
|
|
[(loop-clause exp bs)
|
|
|
|
|
(values (cons exp body-rev)
|
|
|
|
|
(append bindings bs))]
|
|
|
|
|
[(directive kw exp)
|
|
|
|
|
(values (list* exp kw body-rev)
|
|
|
|
|
bindings)])))
|
|
|
|
|
#`(#,(reverse br)
|
|
|
|
|
#,binds))
|
|
|
|
|
|
2019-05-13 15:56:57 +00:00
|
|
|
|
;; iter-clause (Listof Binding) -> (U iter-clause directive)
|
|
|
|
|
(define-for-syntax (analyze-for-clause clause ctx)
|
|
|
|
|
(define/with-syntax ([y y- τ-y] ...) ctx)
|
2019-04-30 21:42:03 +00:00
|
|
|
|
(syntax-parse clause
|
|
|
|
|
#:datum-literals (:)
|
|
|
|
|
[[x:id seq:expr]
|
|
|
|
|
#:and (~typecheck
|
2019-05-13 15:56:57 +00:00
|
|
|
|
[[y ≫ y-- : τ-y] ... ⊢ seq ≫ seq- (⇒ : τ-seq)])
|
2019-04-30 21:42:03 +00:00
|
|
|
|
#:fail-unless (pure? #'seq-) "pure"
|
2019-05-13 15:56:57 +00:00
|
|
|
|
#:with x- (generate-temporary #'x)
|
2019-04-30 21:42:03 +00:00
|
|
|
|
#:do [(define-values (seq-- τ-elems) (make-sequence #'seq- #'τ-seq))]
|
2019-05-13 15:56:57 +00:00
|
|
|
|
(loop-clause (substs #'(y- ...) #'(y-- ...)
|
|
|
|
|
#`[x- #,seq--]
|
|
|
|
|
free-identifier=?)
|
|
|
|
|
(list #`(x x- #,τ-elems)))]
|
2019-04-30 21:42:03 +00:00
|
|
|
|
[[x:id : τ:type seq:expr]
|
2019-05-13 15:56:57 +00:00
|
|
|
|
#:with seq+ (add-expected-type #'seq #'τ.norm)
|
|
|
|
|
#:do [(match-define (list seq- (list (list x- τ-elems)))
|
|
|
|
|
(analyze-for-clause (syntax/loc clause [x seq+])))]
|
2019-04-30 21:42:03 +00:00
|
|
|
|
#:fail-unless (<: τ-elems #'τ.norm) "unexpected type"
|
2019-05-13 15:56:57 +00:00
|
|
|
|
(loop-clause #`[#,x- #,seq-]
|
|
|
|
|
(list #`(x #,x- τ.norm)))]
|
2019-04-30 21:42:03 +00:00
|
|
|
|
[[(k:id v:id) hash-seq:expr]
|
|
|
|
|
#:and (~typecheck
|
2019-05-13 15:56:57 +00:00
|
|
|
|
[[y ≫ y-- : τ-y] ... ⊢ hash-seq ≫ hash-seq- (⇒ : (~Hash K V))])
|
2019-04-30 21:42:03 +00:00
|
|
|
|
#:fail-unless (pure? #'hash-seq-) "pure"
|
2019-05-13 15:56:57 +00:00
|
|
|
|
#:with (k- v-) (generate-temporaries #'(k v))
|
|
|
|
|
(loop-clause (substs #'(y- ...) #'(y-- ...)
|
|
|
|
|
#`[(k- v-) (in-hash- hash-seq-)]
|
|
|
|
|
free-identifier=?)
|
|
|
|
|
(list #'(k k- K) #'(v v- V)))]
|
2019-04-30 21:42:03 +00:00
|
|
|
|
[(dir:keyword pred)
|
|
|
|
|
#:and (~typecheck
|
2019-05-13 15:56:57 +00:00
|
|
|
|
[[y ≫ y-- : τ-y] ... ⊢ pred ≫ pred- (⇐ : Bool)])
|
2019-04-30 21:42:03 +00:00
|
|
|
|
#:fail-unless (pure? #'pred-) "pure"
|
2019-05-13 15:56:57 +00:00
|
|
|
|
(directive #'dir (substs #'(y- ...) #'(y-- ...)
|
|
|
|
|
#'pred-
|
|
|
|
|
free-identifier=?))]))
|
2019-04-30 21:42:03 +00:00
|
|
|
|
|
|
|
|
|
;; Expression Type -> (Values Expression Type)
|
|
|
|
|
;; Determine what kind of sequence we're dealing with;
|
|
|
|
|
;; if it's not already in Sequence form, wrap the expression in the appropriate in-* form
|
|
|
|
|
;; also figure out what the type of elements are to associate with the loop variable
|
|
|
|
|
;; hashes handled separately
|
|
|
|
|
(define-for-syntax (make-sequence e τ)
|
|
|
|
|
(syntax-parse τ
|
|
|
|
|
[(~Sequence t)
|
|
|
|
|
(values e #'t)]
|
|
|
|
|
[(~List t)
|
|
|
|
|
(values #`(in-list- #,e) #'t)]
|
|
|
|
|
[(~Set t)
|
|
|
|
|
(values #`(in-set- #,e) #'t)]
|
|
|
|
|
[_
|
|
|
|
|
(type-error #:src e
|
2019-05-10 14:28:42 +00:00
|
|
|
|
#:msg "not an iterable type: ~a" τ)]))
|
2019-04-30 21:42:03 +00:00
|
|
|
|
|
2020-08-17 15:24:06 +00:00
|
|
|
|
(define-for-syntax (bind-renames renames body)
|
|
|
|
|
(syntax-parse renames
|
|
|
|
|
[([x:id x-:id] ...)
|
|
|
|
|
#:with (x-- ...) (map syntax-local-identifier-as-binding (syntax->list #'(x- ...)))
|
|
|
|
|
(quasisyntax/loc body
|
|
|
|
|
(let- ()
|
|
|
|
|
(define-syntax x (make-variable-like-transformer #'x--)) ...
|
|
|
|
|
#,body))]))
|
2019-04-30 21:42:03 +00:00
|
|
|
|
|
|
|
|
|
(define-typed-syntax for/fold
|
2020-10-22 20:46:33 +00:00
|
|
|
|
[(for/fold ([acc:id (~optional (~datum :)) τ-acc init] ...+)
|
2019-04-30 21:42:03 +00:00
|
|
|
|
(clause:iter-clause
|
|
|
|
|
...)
|
|
|
|
|
e-body ...+) ≫
|
2020-10-22 20:46:33 +00:00
|
|
|
|
[⊢ init ≫ init- (⇐ : τ-acc)] ...
|
|
|
|
|
#:fail-unless (all-pure? #'(init- ...)) "expression must be pure"
|
2019-05-13 15:56:57 +00:00
|
|
|
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
2020-10-22 20:46:33 +00:00
|
|
|
|
#: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 ...))]
|
2019-04-30 21:42:03 +00:00
|
|
|
|
-------------------------------------------------------
|
2020-10-22 20:46:33 +00:00
|
|
|
|
[⊢ (values->tuple #,num-accs
|
|
|
|
|
(for/fold- ([acc- init-] ...)
|
|
|
|
|
clauses-
|
|
|
|
|
#,(bind-renames #'([x-- x-] ...) #`(tuple->values #,num-accs e-body-))))
|
|
|
|
|
(⇒ : body-ty)
|
2019-04-30 21:42:03 +00:00
|
|
|
|
(⇒ ν-ep (τ-ep ...))
|
|
|
|
|
(⇒ ν-s (τ-s ...))
|
|
|
|
|
(⇒ ν-f (τ-f ...))]]
|
2020-10-22 20:46:33 +00:00
|
|
|
|
[(for/fold (accs ... [acc:id init] more-accs ...)
|
2019-04-30 21:42:03 +00:00
|
|
|
|
clauses
|
|
|
|
|
e-body ...+) ≫
|
|
|
|
|
[⊢ init ≫ _ (⇒ : τ-acc)]
|
|
|
|
|
---------------------------------------------------
|
2020-10-22 20:46:33 +00:00
|
|
|
|
[≻ (for/fold (accs ... [acc τ-acc init] more-accs ...)
|
2019-04-30 21:42:03 +00:00
|
|
|
|
clauses
|
|
|
|
|
e-body ...)]])
|
2019-05-13 19:35:38 +00:00
|
|
|
|
|
2020-10-22 20:46:33 +00:00
|
|
|
|
(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 ...)))])])
|
|
|
|
|
|
2019-05-13 19:35:38 +00:00
|
|
|
|
(define-typed-syntax (for/list (clause:iter-clause ...)
|
|
|
|
|
e-body ...+) ≫
|
|
|
|
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
2020-08-17 15:24:06 +00:00
|
|
|
|
[[x ≫ x-- : τ] ... ⊢ (block e-body ...) ≫ e-body-
|
2019-05-13 19:35:38 +00:00
|
|
|
|
(⇒ : τ-body)
|
|
|
|
|
(⇒ ν-ep (~effs τ-ep ...))
|
|
|
|
|
(⇒ ν-s (~effs τ-s ...))
|
|
|
|
|
(⇒ ν-f (~effs τ-f ...))]
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
[⊢ (for/list- clauses-
|
2020-08-17 15:24:06 +00:00
|
|
|
|
#,(bind-renames #'([x-- x-] ...) #'e-body-))
|
|
|
|
|
(⇒ : (List τ-body))
|
|
|
|
|
(⇒ ν-ep (τ-ep ...))
|
|
|
|
|
(⇒ ν-s (τ-s ...))
|
|
|
|
|
(⇒ ν-f (τ-f ...))])
|
2019-05-13 19:35:38 +00:00
|
|
|
|
|
|
|
|
|
(define-typed-syntax (for/set (clause:iter-clause ...)
|
|
|
|
|
e-body ...+) ≫
|
|
|
|
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
2020-08-17 15:24:06 +00:00
|
|
|
|
[[x ≫ x-- : τ] ... ⊢ (block e-body ...) ≫ e-body-
|
2019-05-13 19:35:38 +00:00
|
|
|
|
(⇒ : τ-body)
|
|
|
|
|
(⇒ ν-ep (~effs τ-ep ...))
|
|
|
|
|
(⇒ ν-s (~effs τ-s ...))
|
|
|
|
|
(⇒ ν-f (~effs τ-f ...))]
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
[⊢ (for/set- clauses-
|
2020-08-17 15:24:06 +00:00
|
|
|
|
#,(bind-renames #'([x-- x-] ...) #'e-body-))
|
|
|
|
|
(⇒ : (Set τ-body))
|
|
|
|
|
(⇒ ν-ep (τ-ep ...))
|
|
|
|
|
(⇒ ν-s (τ-s ...))
|
|
|
|
|
(⇒ ν-f (τ-f ...))])
|
2019-05-13 19:35:38 +00:00
|
|
|
|
|
|
|
|
|
(define-typed-syntax (for/sum (clause ...)
|
|
|
|
|
e-body ...+) ≫
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
[≻ (for/fold ([acc 0])
|
|
|
|
|
(clause ...)
|
|
|
|
|
(+ acc (let () e-body ...)))])
|
2019-05-21 20:56:53 +00:00
|
|
|
|
|
|
|
|
|
(define-typed-syntax (for (clause ...)
|
|
|
|
|
e-body ...+) ≫
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
[≻ (for/fold ([acc unit])
|
|
|
|
|
(clause ...)
|
|
|
|
|
e-body ...
|
|
|
|
|
acc)])
|
|
|
|
|
|
|
|
|
|
(define-typed-syntax (for/first (clause:iter-clause ...)
|
|
|
|
|
e-body ...+) ≫
|
|
|
|
|
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
2020-08-17 15:24:06 +00:00
|
|
|
|
[[x ≫ x-- : τ] ... ⊢ (block e-body ...) ≫ e-body-
|
2019-05-21 20:56:53 +00:00
|
|
|
|
(⇒ : τ-body)
|
|
|
|
|
(⇒ ν-ep (~effs τ-ep ...))
|
|
|
|
|
(⇒ ν-s (~effs τ-s ...))
|
|
|
|
|
(⇒ ν-f (~effs τ-f ...))]
|
|
|
|
|
[[res ≫ _ : τ-body] ⊢ res ≫ res- (⇒ : _)]
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
[⊢ (let- ()
|
|
|
|
|
(define- res-
|
|
|
|
|
(for/first- clauses-
|
2020-08-17 15:24:06 +00:00
|
|
|
|
#,(bind-renames #'([x-- x-] ...) #'e-body-)))
|
2019-05-21 20:56:53 +00:00
|
|
|
|
(if- res-
|
|
|
|
|
(some res-)
|
|
|
|
|
none))
|
|
|
|
|
(⇒ : (Maybe τ-body))
|
|
|
|
|
(⇒ ν-ep (τ-ep ...))
|
|
|
|
|
(⇒ ν-s (τ-s ...))
|
|
|
|
|
(⇒ ν-f (τ-f ...))])
|
2020-10-21 15:05:46 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-typed-syntax (in-hash-values h) ≫
|
|
|
|
|
[⊢ h ≫ h- (⇒ : (~Hash K V))]
|
|
|
|
|
--------------------
|
|
|
|
|
[⊢ (#%app- in-hash-values- h-) (⇒ : (Sequence V))])
|
|
|
|
|
|
|
|
|
|
(define-typed-syntax (in-hash-keys h) ≫
|
|
|
|
|
[⊢ h ≫ h- (⇒ : (~Hash K V))]
|
|
|
|
|
--------------------
|
|
|
|
|
[⊢ (#%app- in-hash-keys- h-) (⇒ : (Sequence K))])
|