@effekt-lang/effekt 0.2.1 → 0.2.2

package/libraries/chez/callcc/tail.ss

@@ -0,0 +1,76 @@
+;;; tail.ss
+;;; Copyright (c) 2005, R. Kent Dybvig, Simon L. Peyton Jones, and Amr Sabry
+
+;;; Tail-recursive implementation of the operators
+
+;(case-sensitive #t)
+
+(define-syntax pushPrompt
+  (syntax-rules ()
+    [(_ p e1 e2 ...)
+     ($pushPrompt p (lambda () e1 e2 ...))]))
+
+(define-syntax pushSubCont
+  (syntax-rules ()
+    [(_ subk e1 e2 ...)
+     ($pushSubCont subk (lambda () e1 e2 ...))]))
+
+(define abort)
+(define mk)
+(define base-k)
+
+(define (PushSeg/t k seq)
+  (if (eqv? k base-k)
+      seq
+      (PushSeg k seq)))
+
+(define ($pushPrompt p th)
+  (call/cc (lambda (k)
+    (set! mk (PushP p (PushSeg/t k mk)))
+    (abort th))))
+
+(define (state init th)
+  (define b (box init))
+  (set! mk (PushState b #f mk))
+  (th b))
+
+(define (getter ref)
+  (lambda () (unbox ref)))
+
+(define (setter ref)
+  (lambda (v) (set-box! ref v)))
+
+(define (withSubCont p f)
+  (let-values ([(subk mk*) (splitSeq p mk)])
+    (set! mk mk*)
+    (call/cc (lambda (k)
+      (abort (lambda () (f (PushSeg/t k subk))))))))
+
+(define ($pushSubCont subk th)
+  (call/cc (lambda (k)
+    (set! mk (appendSeq subk (PushSeg/t k mk)))
+    (abort th))))
+
+(define newPrompt (lambda () (string #\p)))
+
+(define (run th)
+  (set! mk (EmptyS))
+  (underflow
+   (call/cc/base
+    (lambda (k_1)
+      (set! base-k k_1)
+      ((call/cc (lambda (k_2)
+         (set! abort k_2)
+         (abort th))))))))
+
+(define (underflow v)
+  (Seq-case mk
+    [(EmptyS) v]
+    [(PushP _ mk*) (set! mk mk*) (underflow v)]
+    [(PushState b _ mk*) (set! mk mk*) (underflow v)]
+    [(PushSeg k mk*) (set! mk mk*) (k v)]))
+
+(define (go)
+  (new-cafe
+    (lambda (x)
+      (run (lambda () (eval x))))))

package/libraries/chez/callcc/tail0.ss

@@ -0,0 +1,89 @@
+;;; tail.ss
+;;; Copyright (c) 2005, R. Kent Dybvig, Simon L. Peyton Jones, and Amr Sabry
+
+;;; Tail-recursive implementation of the operators
+
+;(case-sensitive #t)
+
+(define-syntax pushPrompt
+  (syntax-rules ()
+    [(_ p e1 e2 ...)
+     ($pushPrompt p (lambda () e1 e2 ...))]))
+
+(define-syntax pushSubCont
+  (syntax-rules ()
+    [(_ subk e1 e2 ...)
+     ($pushSubCont subk (lambda () e1 e2 ...))]))
+
+(define abort)
+(define mk)
+(define base-k)
+
+(define ($pushPrompt p th)
+  (call/cc (lambda (k)
+    (pushFrame k)
+    (set! mk (cons (make-Stack (list) (make-arena) p) mk))
+    (abort th))))
+
+(define (with-region body)
+  (let* ([stack (car mk)]
+         [arena (Stack-arena stack)])
+    (body arena)))
+
+(define (withSubCont p f)
+  (call/cc (lambda (k)
+    (pushFrame k)
+    (let-values ([(subk mk*) (splitSeq p mk)])
+      (set! mk mk*)
+      (abort (lambda () (f subk)))))))
+
+(define (pushFrame f)
+  (if (eqv? f base-k) (values)
+    (if (null? mk) (error "ERROR! Cannot push on empty meta cont" #f)
+        (let* ([stack (car mk)]
+              [frames (Stack-frames stack)]
+              [arena (Stack-arena stack)]
+              [prompt (Stack-prompt stack)]
+              [rest  (cdr mk)])
+          (set! mk (cons (make-Stack (cons f frames) arena prompt) rest))))))
+
+(define ($pushSubCont subk th)
+  (call/cc (lambda (k)
+    (pushFrame k)
+    (set! mk (appendSeq subk mk))
+    (abort th))))
+
+(define newPrompt (lambda () (string #\p)))
+
+(define (run th)
+  (define global (make-Stack '() (make-arena) (newPrompt)))
+  (set! mk (list global))
+  (underflow
+   (call/cc
+    (lambda (k_1)
+      (set! base-k k_1)
+      ((call/cc (lambda (k_2)
+         (set! abort k_2)
+         (abort th))))))))
+
+(define (underflow v)
+  (if (null? mk) v
+    (let* ([stack (car mk)]
+           [frames (Stack-frames stack)]
+           [arena (Stack-arena stack)]
+           [prompt (Stack-prompt stack)]
+           [rest  (cdr mk)])
+      (if (null? frames) (begin (set! mk rest) (underflow v))
+          (begin
+            (set! mk (cons (make-Stack (cdr frames) arena prompt) rest))
+            ((car frames) v))))))
+
+
+(define-syntax shift0-at
+  (syntax-rules ()
+    [(_ P id exp ...)
+     (withSubCont
+      P
+      (lambda (s)
+         (let ([id (lambda (v) (pushSubCont s v))])
+           exp ...)))]))

package/libraries/chez/common/effekt_matching.ss

@@ -0,0 +1,100 @@
+; Matcher = (SCRUTINEE, ANS -> () -> R, () -> R, (ANS -> () -> R) -> R) -> R
+
+(define done (lambda (matched) (matched)))
+
+(define (any m matched failed k)
+  (k (matched m)))
+
+(define (ignore m matched failed k)
+  (k matched))
+
+(define (literal l)
+  (lambda (m matched failed k)
+    (if (equal_impl m l)
+        (k matched)
+        (failed))))
+
+(define (bind p)
+  (lambda (m matched failed k)
+    (p m (matched m) failed k)))
+
+;; for this record
+; (define-record Pair (fst snd))
+
+;; this is what we need to generate
+; (define (match-Pair p1 p2)
+;   (lambda (m matched failed k)
+;     (if (Pair? m)
+;       (p1 (Pair-fst m) matched failed (lambda (matched)
+;         (p2 (Pair-snd m) matched failed k)))
+;       (failed))))
+
+
+(define-syntax define-matcher
+  (syntax-rules ()
+    [(_ name pred ())
+      (define (name)
+        (lambda (sc matched failed k)
+          (if (pred sc) (k matched) (failed))))]
+    [(_ name pred ((p1 sel1) (p2 sel2) ...))
+     (define (name p1 p2 ...)
+       (lambda (m matched failed k)
+             ;; has correct tag?
+             (if (pred m)
+                 (match-fields m matched failed k ([p1 sel1] [p2 sel2] ...))
+                 (failed))))]))
+
+(define-syntax match-fields
+  (syntax-rules ()
+    [(_ m matched failed k ()) (k matched)]
+    [(_ m matched failed k ([p1 sel1] [p2 sel2] ...))
+     (p1 (sel1 m) matched failed (lambda (matched)
+       (match-fields m matched failed k ([p2 sel2] ...))))]))
+
+
+; forces the pattern match
+(define-syntax pattern-match
+  (syntax-rules ()
+    [(_ m ()) (raise "no patterns provided")]
+    [(_ m ([p1 k1] [p2 k2]...))
+      (p1 m k1 (lambda () (pattern-match m ([p2 k2] ...))) done)]))
+
+;; Examples
+
+; (define-matcher match-Pair2 Pair? ([p1 Pair-fst] [p2 Pair-snd]))
+
+; (define (match sc p matched)
+;   (p sc matched abort done))
+
+; (display (match (make-Pair 1 2)
+;   (match-Pair2 any any)
+;   (lambda (x) (lambda (y) (lambda () (+ x y))))))
+
+; (display (match 3
+;   (match-Pair2 any any)
+;   (lambda (x) (lambda (y) (lambda () (+ x y))))))
+
+; (display (match (make-Pair 1 2)
+;   (match-Pair2 any (match-Pair2 ignore any))
+;   (lambda (x) (lambda (y) (lambda () (+ x y))))))
+
+; (display (match (make-Pair 1 (make-Pair 2 3))
+;   (match-Pair2 any (match-Pair2 ignore any))
+;   (lambda (x) (lambda (y) (lambda () (+ x y))))))
+
+; (display (match (make-Pair (make-Pair 1 2) (make-Pair 3 4))
+;   (match-Pair (match-Pair ignore any) (match-Pair ignore any))
+;   (lambda (x) (lambda (y) (lambda () (+ x y))))))
+
+; (display (match (make-Pair (make-Pair 1 2) (make-Pair 10 15))
+;   (match-Pair2 (match-Pair2 any ignore) (match-Pair2 ignore any))
+;   (lambda (x) (lambda (y) (lambda () (+ x y))))))
+
+; (display (match (make-Pair (make-Pair 1 2) (make-Pair 10 15))
+;   (match-Pair2 (match-Pair2 any ignore) (match-Pair2 ignore any))
+;   (lambda (x) (lambda (y) (lambda () (+ x y))))))
+
+; (display (pattern-match (make-Pair 1 2)
+;   ([(match-Pair2 (match-Pair2 any ignore) (match-Pair2 ignore any))
+;       (lambda (x) (lambda (y) (lambda () (+ x y))))]
+;    [any (lambda (x) (lambda () (Pair-snd x)))])))

package/libraries/chez/common/effekt_primitives.ss

@@ -0,0 +1,97 @@
+(define (show_impl obj)
+  (cond
+    [(number? obj) (show-number obj)]
+    [(string? obj) obj]
+    [(boolean? obj) (if obj "true" "false")]
+    ; [(record? obj)
+    ;   (let* ([rtd (record-rtd obj)]
+    ;          [name (symbol->string (record-type-name rtd))])
+    ;     ;; how can we show the fields?
+    ;     (string-append name))]
+    [(list? obj) (map show_impl obj)]
+    [(record? obj) (show-record obj)]
+    [else (generic-show obj)]))
+
+(define (generic-show obj)
+  (define out (open-output-string))
+  (write obj out)
+  (get-output-string out))
+
+; conform with the JS way of printing numbers
+(define (show-number n)
+  (if (integer? n) (number->string (exact n)) (number->string n)))
+
+; here we use eval to find the show function defined with the record...
+; (define (show-record rec)
+;   (let* ([rtd (record-rtd rec)]
+;          [showName (string-append "show" (generic-show (record-type-name rtd)))]
+;          [showFun (eval (string->symbol showName))])
+;   (showFun rec)))
+
+; we needed to add a unique id to the types in order to prevent duplicate definitions
+; now for printing, we need to strip the unique id (starting with $) again.
+(define (strip-type-name tpe)
+  (define out "")
+  (define found #f)
+  (for-each
+    (lambda (el)
+      (if (char=? el #\$) (set! found #t) #f)
+      (if found #f (set! out (string-append out (string el)))))
+    (string->list tpe))
+  out)
+
+(define (show-record rec)
+  (let* ([rtd (record-rtd rec)]
+         [unique-tpe (generic-show (record-type-name rtd))]
+         [tpe (strip-type-name unique-tpe)]
+         [fields (record-type-field-names rtd)]
+         [n (vector-length fields)])
+     (define out (string-append tpe "("))
+     (do ([i 0 (+ i 1)])
+         ((= i n))
+       (set! out (string-append out (show_impl ((record-accessor rtd i) rec))))
+       (if (< i (- n 1)) (set! out (string-append out ", "))))
+     (set! out (string-append out ")"))
+     out))
+
+
+
+(define (println_impl obj)
+  (display (show_impl obj))
+  (newline))
+
+(define (equal_impl obj1 obj2)
+  (equal? obj1 obj2))
+
+(define-syntax thunk
+  (syntax-rules ()
+    [(_ e ...) (lambda () e ...)]))
+
+;; Benchmarking utils
+
+; time in milliseconds
+(define (timed block)
+  (let ([before (current-time)])
+    (block)
+    (let ([after (current-time)])
+      (seconds (time-difference after before)))))
+
+(define (seconds diff)
+  (+ (time-second diff) (/ (time-nanosecond diff) 1000000000.0)))
+
+(define (measure block warmup iterations)
+  (define (run n)
+    (if (<= n 0)
+        '()
+        (begin
+          (collect)
+          (cons (timed block) (run (- n 1))))))
+  (begin
+    (run warmup)
+    (run iterations)))
+
+(define (hole)
+  (raise
+    (condition
+      (make-error)
+      (make-message-condition "not implemented"))))

package/libraries/chez/common/immutable/cslist.effekt

@@ -0,0 +1,31 @@
+module immutable/cslist
+
+import immutable/list
+
+// a chez scheme cons list
+extern type CSList[A]
+extern pure def cons[A](el: A, rest: CSList[A]): CSList[A] =
+  "(cons ${el} ${rest})"
+
+extern pure def nil[A](): CSList[A] =
+  "(list)"
+
+extern pure def isEmpty[A](l: CSList[A]): Boolean =
+  "(null? ${l})"
+
+// unsafe!
+extern pure def head[A](l: CSList[A]): A =
+  "(car ${l})"
+
+// unsafe!
+extern pure def tail[A](l: CSList[A]): CSList[A] =
+  "(cdr ${l})"
+
+
+def toChez[A](l: List[A]): CSList[A] = l match {
+  case Nil() => nil()
+  case Cons(a, rest) => cons(a, rest.toChez)
+}
+
+def fromChez[A](l: CSList[A]): List[A] =
+  if (l.isEmpty) Nil() else Cons(l.head, l.tail.fromChez)

package/libraries/chez/common/immutable/dequeue.effekt

@@ -0,0 +1,78 @@
+module immutable/dequeue
+
+import immutable/list
+import immutable/option
+
+// An implementation of a functional dequeue, using Okasaki's
+// bankers dequeue implementation.
+//
+// Translation from the Haskell implementation:
+//   https://hackage.haskell.org/package/dequeue-0.1.12/docs/src/Data-Dequeue.html#Dequeue
+record Dequeue[R](front: List[R], frontSize: Int, rear: List[R], rearSize: Int)
+
+def emptyQueue[R](): Dequeue[R] = Dequeue(Nil(), 0, Nil(), 0)
+
+def isEmpty[R](dq: Dequeue[R]): Boolean = dq match {
+    case Dequeue(f, fs, r, rs) => (fs == 0) && (rs == 0)
+}
+
+def size[R](dq: Dequeue[R]): Int = dq match {
+    case Dequeue(f, fs, r, rs) => fs + rs
+}
+
+def first[R](dq: Dequeue[R]): Option[R] = dq match {
+    case Dequeue(f, fs, r, rs) =>
+      if ((fs == 0) && (rs == 1)) { r.headOption }
+      else { f.headOption }
+}
+
+def last[R](dq: Dequeue[R]): Option[R] = dq match {
+    case Dequeue(f, fs, r, rs) =>
+      if ((fs == 1) && (rs == 0)) { f.headOption }
+      else { r.headOption }
+}
+
+def check[R](dq: Dequeue[R]): Dequeue[R] = dq match {
+    case Dequeue(f, fs, r, rs) =>
+        val c = 4;
+        val size1 = (fs + rs) / 2;
+        val size2 = (fs + rs) - size1;
+
+        if (fs > c * rs + 1) {
+            val front = f.take(size1);
+            val rear = r.append(f.drop(size1).reverse);
+            Dequeue(front, size1, rear, size2)
+        } else if (rs > c * fs + 1) {
+            val front = f.append(r.drop(size1).reverse);
+            val rear = r.take(size1);
+            Dequeue(front, size2, rear, size1)
+        } else {
+            dq
+        }
+}
+
+def pushFront[R](dq: Dequeue[R], el: R): Dequeue[R] = dq match {
+    case Dequeue(f, fs, r, rs) => Dequeue(Cons(el, f), fs + 1, r, rs).check
+}
+
+def popFront[R](dq: Dequeue[R]): Option[(R, Dequeue[R])] = dq match {
+    case Dequeue(Nil(), fs, Cons(x, Nil()), rs) =>
+        Some((x, emptyQueue()))
+    case Dequeue(Nil(), fs, r, rs) =>
+        None()
+    case Dequeue(Cons(x, rest), fs, r, rs) =>
+        Some((x, Dequeue(rest, fs - 1, r, rs).check))
+}
+
+def pushBack[R](dq: Dequeue[R], el: R): Dequeue[R] = dq match {
+    case Dequeue(f, fs, r, rs) => Dequeue(f, fs, Cons(el, r), rs + 1).check
+}
+
+def popBack[R](dq: Dequeue[R]): Option[(R, Dequeue[R])] = dq match {
+    case Dequeue(Cons(x, Nil()), fs, Nil(), rs) =>
+        Some((x, emptyQueue()))
+    case Dequeue(f, fs, Nil(), rs) =>
+        None()
+    case Dequeue(f, fs, Cons(x, rest), rs) =>
+        Some((x, Dequeue(f, fs, rest, rs - 1).check))
+}