start on for loops
This commit is contained in:
parent
899d8c460d
commit
1b2527920e
|
@ -717,7 +717,7 @@
|
||||||
(free-identifier=? #'X #'Y)]
|
(free-identifier=? #'X #'Y)]
|
||||||
[((~∀ (X:id ...) τ1) (~∀ (Y:id ...) τ2))
|
[((~∀ (X:id ...) τ1) (~∀ (Y:id ...) τ2))
|
||||||
#:when (stx-length=? #'(X ...) #'(Y ...))
|
#:when (stx-length=? #'(X ...) #'(Y ...))
|
||||||
#:with τ2-X/Y (substs #'(X ...) #'(Y ...) #'τ2)
|
#:with τ2-X/Y (substs #'(Y ...) #'(X ...) #'τ2)
|
||||||
(<: #'τ1 #'τ2-X/Y)]
|
(<: #'τ1 #'τ2-X/Y)]
|
||||||
[((~Base τ1:id) (~Base τ2:id))
|
[((~Base τ1:id) (~Base τ2:id))
|
||||||
(free-identifier=? #'τ1 #'τ2)]
|
(free-identifier=? #'τ1 #'τ2)]
|
||||||
|
|
|
@ -0,0 +1,125 @@
|
||||||
|
#lang turnstile
|
||||||
|
|
||||||
|
(provide for/fold)
|
||||||
|
|
||||||
|
(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))
|
||||||
|
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(struct loop-clause (exp bindings) #:transparent)
|
||||||
|
(struct directive (kw exp) #:transparent))
|
||||||
|
|
||||||
|
|
||||||
|
(define-for-syntax (analyze-for-clauses clauses)
|
||||||
|
(define-values (br binds)
|
||||||
|
(for/fold ([body-rev '()]
|
||||||
|
[bindings '()])
|
||||||
|
([clause (in-syntax clauses)])
|
||||||
|
(match (analyze-for-clause clause)
|
||||||
|
[(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))
|
||||||
|
|
||||||
|
;; iter-clause -> (U iter-clause directive)
|
||||||
|
(define-for-syntax (analyze-for-clause clause)
|
||||||
|
(syntax-parse clause
|
||||||
|
#:datum-literals (:)
|
||||||
|
[[x:id seq:expr]
|
||||||
|
#:and (~typecheck
|
||||||
|
[⊢ seq ≫ seq- (⇒ : τ-seq)])
|
||||||
|
#:fail-unless (pure? #'seq-) "pure"
|
||||||
|
#:do [(define-values (seq-- τ-elems) (make-sequence #'seq- #'τ-seq))]
|
||||||
|
(loop-clause #`[x #,seq--]
|
||||||
|
(list #`(x #,τ-elems)))]
|
||||||
|
[[x:id : τ:type seq:expr]
|
||||||
|
#:do [(match-define (list seq- (list (list y τ-elems)))
|
||||||
|
(analyze-for-clause (syntax/loc clause [x seq])))]
|
||||||
|
#:fail-unless (<: τ-elems #'τ.norm) "unexpected type"
|
||||||
|
(loop-clause #`[#,y #,seq-]
|
||||||
|
(list #`(#,y τ.norm)))]
|
||||||
|
[[(k:id v:id) hash-seq:expr]
|
||||||
|
#:and (~typecheck
|
||||||
|
[⊢ hash-seq ≫ hash-seq- (⇒ : (~Hash K V))])
|
||||||
|
#:fail-unless (pure? #'hash-seq-) "pure"
|
||||||
|
(loop-clause #`[(k v) (in-hash- hash-seq-)]
|
||||||
|
(list #'(k K) #'(v V)))]
|
||||||
|
[(dir:keyword pred)
|
||||||
|
#:and (~typecheck
|
||||||
|
[⊢ pred ≫ pred- (⇐ : Bool)])
|
||||||
|
#:fail-unless (pure? #'pred-) "pure"
|
||||||
|
(directive #'dir #'pred-)]))
|
||||||
|
|
||||||
|
;; 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
|
||||||
|
#:msg "not an iterable type: " τ)]))
|
||||||
|
|
||||||
|
|
||||||
|
(define-typed-syntax for/fold
|
||||||
|
[(for/fold ([acc:id (~optional (~datum :)) τ-acc init])
|
||||||
|
(clause:iter-clause
|
||||||
|
...)
|
||||||
|
e-body ...+) ≫
|
||||||
|
[⊢ init ≫ init- (⇐ : τ-acc)]
|
||||||
|
#:fail-unless (pure? #'init-) "expression must be pure"
|
||||||
|
#:with (clauses- ([x τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||||
|
[[x ≫ x- : τ] ...
|
||||||
|
[acc ≫ acc- : τ-acc] ⊢ (begin e-body ...) ≫ e-body-
|
||||||
|
(⇐ : τ-acc)
|
||||||
|
(⇒ ν-ep (~effs τ-ep ...))
|
||||||
|
(⇒ ν-s (~effs τ-s ...))
|
||||||
|
(⇒ ν-f (~effs τ-f ...))]
|
||||||
|
#:with clauses-- (substs #'(x- ...) #'(x ...) #'clauses-)
|
||||||
|
-------------------------------------------------------
|
||||||
|
[⊢ (for/fold- ([acc- init-])
|
||||||
|
(#,@#'clauses--)
|
||||||
|
e-body-)
|
||||||
|
(⇒ : τ-acc)
|
||||||
|
(⇒ ν-ep (τ-ep ...))
|
||||||
|
(⇒ ν-s (τ-s ...))
|
||||||
|
(⇒ ν-f (τ-f ...))]]
|
||||||
|
[(for/fold ([acc:id init])
|
||||||
|
clauses
|
||||||
|
e-body ...+) ≫
|
||||||
|
[⊢ init ≫ _ (⇒ : τ-acc)]
|
||||||
|
---------------------------------------------------
|
||||||
|
[≻ (for/fold ([acc τ-acc init])
|
||||||
|
clauses
|
||||||
|
e-body ...)]])
|
|
@ -8,8 +8,7 @@
|
||||||
rest
|
rest
|
||||||
member?
|
member?
|
||||||
empty?
|
empty?
|
||||||
for
|
reverse)
|
||||||
for/fold)
|
|
||||||
|
|
||||||
(require "core-types.rkt")
|
(require "core-types.rkt")
|
||||||
(require (postfix-in - racket/list))
|
(require (postfix-in - racket/list))
|
||||||
|
@ -35,38 +34,6 @@
|
||||||
----------------------------------------
|
----------------------------------------
|
||||||
[⊢ (cons- e1- e2-) ⇒ τ-l])
|
[⊢ (cons- e1- e2-) ⇒ τ-l])
|
||||||
|
|
||||||
(define-typed-syntax (for/fold [acc:id e-acc]
|
|
||||||
[x:id e-list]
|
|
||||||
e-body ...+) ≫
|
|
||||||
[⊢ e-list ≫ e-list- ⇒ (~List τ-l)]
|
|
||||||
#:fail-unless (pure? #'e-list-) "expression must be pure"
|
|
||||||
[⊢ e-acc ≫ e-acc- ⇒ τ-a]
|
|
||||||
#:fail-unless (pure? #'e-acc-) "expression must be pure"
|
|
||||||
[[x ≫ x- : τ-l] [acc ≫ acc- : τ-a] ⊢ (begin e-body ...) ≫ e-body- ⇒ τ-b]
|
|
||||||
#:fail-unless (pure? #'e-body-) "body must be pure"
|
|
||||||
#:fail-unless (<: #'τ-b #'τ-a)
|
|
||||||
"loop body doesn't match accumulator"
|
|
||||||
-------------------------------------------------------
|
|
||||||
[⊢ (for/fold- ([acc- e-acc-])
|
|
||||||
([x- (in-list- e-list-)])
|
|
||||||
e-body-)
|
|
||||||
⇒ τ-b])
|
|
||||||
|
|
||||||
(define-typed-syntax (for ([x:id e-list] ...)
|
|
||||||
e-body ...+) ≫
|
|
||||||
[⊢ e-list ≫ e-list- ⇒ (~List τ-l)] ...
|
|
||||||
#:fail-unless (all-pure? #'(e-list- ...)) "expressions must be pure"
|
|
||||||
[[x ≫ x- : τ-l] ... ⊢ (begin e-body ...) ≫ e-body- (⇒ : τ-b)
|
|
||||||
(⇒ ν-ep (~effs eps ...))
|
|
||||||
(⇒ ν-f (~effs fs ...))
|
|
||||||
(⇒ ν-s (~effs ss ...))]
|
|
||||||
-------------------------------------------------------
|
|
||||||
[⊢ (for- ([x- (in-list- e-list-)] ...)
|
|
||||||
e-body-) (⇒ : ★/t)
|
|
||||||
(⇒ ν-ep (eps ...))
|
|
||||||
(⇒ ν-f (fs ...))
|
|
||||||
(⇒ ν-s (ss ...))])
|
|
||||||
|
|
||||||
(define-typed-syntax (empty? e) ≫
|
(define-typed-syntax (empty? e) ≫
|
||||||
[⊢ e ≫ e- ⇒ (~List _)]
|
[⊢ e ≫ e- ⇒ (~List _)]
|
||||||
#:fail-unless (pure? #'e-) "expression must be pure"
|
#:fail-unless (pure? #'e-) "expression must be pure"
|
||||||
|
@ -96,3 +63,6 @@
|
||||||
|
|
||||||
(define- (member?- v l)
|
(define- (member?- v l)
|
||||||
(and- (member- v l) #t))
|
(and- (member- v l) #t))
|
||||||
|
|
||||||
|
(require/typed racket/base
|
||||||
|
[reverse : (∀ (X) (→fn (List X) (List X)))])
|
||||||
|
|
|
@ -22,6 +22,8 @@
|
||||||
(define-primop <= (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
(define-primop <= (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
||||||
(define-primop >= (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
(define-primop >= (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
||||||
(define-primop = (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
(define-primop = (→ Int Int (Computation (Value Bool) (Endpoints) (Roles) (Spawns))))
|
||||||
|
(define-primop even? (→fn Int Bool))
|
||||||
|
(define-primop odd? (→fn Int Bool))
|
||||||
|
|
||||||
(define-primop bytes->string/utf-8 (→ ByteString (Computation (Value String) (Endpoints) (Roles) (Spawns))))
|
(define-primop bytes->string/utf-8 (→ ByteString (Computation (Value String) (Endpoints) (Roles) (Spawns))))
|
||||||
(define-primop string->bytes/utf-8 (→ String (Computation (Value ByteString) (Endpoints) (Roles) (Spawns))))
|
(define-primop string->bytes/utf-8 (→ String (Computation (Value ByteString) (Endpoints) (Roles) (Spawns))))
|
||||||
|
|
|
@ -41,6 +41,8 @@
|
||||||
(all-from-out "sequence.rkt")
|
(all-from-out "sequence.rkt")
|
||||||
;; hash tables
|
;; hash tables
|
||||||
(all-from-out "hash.rkt")
|
(all-from-out "hash.rkt")
|
||||||
|
;; for loops
|
||||||
|
(all-from-out "for-loops.rkt")
|
||||||
;; DEBUG and utilities
|
;; DEBUG and utilities
|
||||||
print-type print-role
|
print-type print-role
|
||||||
;; Extensions
|
;; Extensions
|
||||||
|
@ -57,6 +59,7 @@
|
||||||
(require "prim.rkt")
|
(require "prim.rkt")
|
||||||
(require "sequence.rkt")
|
(require "sequence.rkt")
|
||||||
(require "hash.rkt")
|
(require "hash.rkt")
|
||||||
|
(require "for-loops.rkt")
|
||||||
|
|
||||||
(require (prefix-in syndicate: syndicate/actor-lang))
|
(require (prefix-in syndicate: syndicate/actor-lang))
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,69 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(require rackunit/turnstile)
|
||||||
|
|
||||||
|
|
||||||
|
(check-type (for/fold ([x 0])
|
||||||
|
([y (list 1 2 3)])
|
||||||
|
x)
|
||||||
|
: Int
|
||||||
|
⇒ 0)
|
||||||
|
|
||||||
|
(check-type (for/fold ([x 0])
|
||||||
|
([y (list 1 2 3)])
|
||||||
|
y)
|
||||||
|
: Int
|
||||||
|
⇒ 3)
|
||||||
|
|
||||||
|
(define-type-alias Inventory (List (Tuple String Int)))
|
||||||
|
|
||||||
|
(define inventory0 (list (tuple "The Wind in the Willows" 5)
|
||||||
|
(tuple "Catch 22" 2)
|
||||||
|
(tuple "Candide" 33)))
|
||||||
|
(check-type (for/fold ([stock 0])
|
||||||
|
([item inventory0])
|
||||||
|
(select 1 item))
|
||||||
|
: Int
|
||||||
|
⇒ 33)
|
||||||
|
|
||||||
|
(check-type (for/fold ([stock 0])
|
||||||
|
([item inventory0])
|
||||||
|
(if (equal? "Catch 22" (select 0 item))
|
||||||
|
(select 1 item)
|
||||||
|
stock))
|
||||||
|
: Int
|
||||||
|
⇒ 2)
|
||||||
|
|
||||||
|
(define (lookup [title : String]
|
||||||
|
[inv : Inventory] -> Int)
|
||||||
|
(for/fold ([stock 0])
|
||||||
|
([item inv])
|
||||||
|
(if (equal? title (select 0 item))
|
||||||
|
(select 1 item)
|
||||||
|
stock)))
|
||||||
|
|
||||||
|
(check-type lookup : (→fn String Inventory Int))
|
||||||
|
|
||||||
|
(define (zip [xs : (List Int)]
|
||||||
|
[ys : (List Int)])
|
||||||
|
((inst reverse (Tuple Int Int))
|
||||||
|
(for/fold ([acc : (List (Tuple Int Int))
|
||||||
|
(list)])
|
||||||
|
([x xs]
|
||||||
|
[y ys])
|
||||||
|
(cons (tuple x y) acc))))
|
||||||
|
|
||||||
|
(check-type (zip (list 1 2 3) (list 4 5 6))
|
||||||
|
: (List (Tuple Int Int))
|
||||||
|
⇒ (list (tuple 1 4) (tuple 2 5) (tuple 3 6)))
|
||||||
|
|
||||||
|
(define (zip-even [xs : (List Int)]
|
||||||
|
[ys : (List Int)])
|
||||||
|
((inst reverse (Tuple Int Int))
|
||||||
|
(for/fold ([acc : (List (Tuple Int Int))
|
||||||
|
(list)])
|
||||||
|
([x xs]
|
||||||
|
#:when (even? x)
|
||||||
|
[y ys]
|
||||||
|
#:when (even? y))
|
||||||
|
(cons (tuple x y) acc))))
|
Loading…
Reference in New Issue