@effekt-lang/effekt 0.2.1 → 0.2.2

package/LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2020 Jonathan Brachthäuser and contributors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

package/README.md

@@ -0,0 +1,36 @@
+# Ξ Effekt
+
+Compared to other languages with effect handlers (and support for polymorphic effects) the Effekt language
+aims to be significantly more lightweight in its concepts.
+
+
+## Disclaimer: Use at your own risk
+
+**Effekt is a research-level language. We are actively working on it and the language (and everything else) is very likely to change.**
+
+Also, Effekt comes with no warranty and there are (probably) many bugs -- If this does not discourage you, feel free to
+play with it and give us your feedback :)
+
+## Installation
+
+You need to have Java (>= 11) and Node (>= 12) and npm installed.
+
+The recommended way of installing Effekt is by running:
+
+```
+npm install -g https://github.com/effekt-lang/effekt/releases/latest/download/effekt.tgz
+```
+
+Alternatively, you can download the `effekt.tgz` file from [another release](https://github.com/effekt-lang/effekt/releases) and then run
+
+```
+npm install -g effekt.tgz
+```
+
+This will make the `effekt` command globally available. You can start the Effekt REPL by entering:
+
+```
+> effekt
+```
+
+You can find more information about the Effekt language and how to use it on the website (<https://effekt-lang.org>).

package/bin/effekt.sh

@@ -0,0 +1,2 @@
+#!/bin/bash
+java -jar "$(npm root -g)/effekt/bin/effekt" $@

package/libraries/chez/THIRD-PARTY.txt

@@ -0,0 +1,11 @@
+The runtime of the callcc version builds on code by R. Kent Dybvig,
+Simon L. Peyton Jones, and Amr Sabry, as presented in:
+
+    Dyvbig, R. K., Jones, S. P., & Sabry, A. (2007).
+    A monadic framework for delimited continuations.
+    Journal of Functional Programming, 17(6), 687-730.
+
+The regular expression implementation is by Dorai Sitaram and
+obtained from:
+
+    <https://github.com/ds26gte/pregexp/blob/master/pregexp.scm>

package/libraries/chez/callcc/datatype.ss

@@ -0,0 +1,188 @@
+;;; datatype.ss
+;;; Copyright (c) 2005, R. Kent Dybvig, Simon L. Peyton Jones, and Amr Sabry
+
+;;; Code for defining datatypes, based on record subtyping.
+
+#|
+
+Description
+-----------
+
+A define-datatype form creates a new datatype with zero or more variants,
+each with its own set of fields.  It produces definitions for a predicate,
+constructors, and a case form.
+
+Syntax:
+
+  <datatype definition> -> (define-datatype <datatype name> <variant>*)
+
+  <datatype name> -> identifier
+
+  <variant> -> (<variant name> <field name>*)
+  <variant name> -> identifier
+  <field name> -> identifier
+
+Products:
+  The definition
+
+    (define-datatype dtname (vname vfield ...))
+
+  produces the following set of variable definitions:
+
+    dtname?       a predicate true only of datatype instances
+    variant ...   a set of constructors for the different variants
+    dtname-case   a case construct for the datatype
+
+  Each constructor accepts one argument for each field of the variant.
+  The case construct has the following syntax:
+
+    (dtname-case <expression> <clause> ...)
+
+  where each <clause> is of the form:
+
+    [(<variant name> <field name>*) <expression>+]
+
+  except that the last must be an else clause of the form
+
+    [else <expression>+]
+
+  if any of the datatype's variants are not represented in the set of
+  clauses.  The clauses may appear in any order and the field names
+  need not be the same as those given in the datatype definition.
+  (They are instead specified positionally.)
+  
+Example:
+
+  (case-sensitive #t)
+
+  (define-datatype AST
+    (Const datum)
+    (Ref var)
+    (If tst thn els)
+    (Fun fmls body)
+    (Call exp0 args))
+
+  (define (parse x)
+    (cond
+      [(symbol? x) (Ref x)]
+      [(pair? x)
+       (case (car x)
+         [(if) (If (parse (cadr x)) (parse (caddr x)) (parse (cadddr x)))]
+         [(fun) (Fun (cadr x) (parse (caddr x)))]
+         [else (Call (parse (car x)) (map parse (cdr x)))])]
+      [else (Const x)]))
+    
+  (define (ev x r)
+    (AST-case x
+      [(Ref v) (cdr (assq v r))]
+      [(Const x) x]
+      [(If tst thn els) (ev (if (ev tst r) thn els) r)]
+      [(Fun fmls body)
+       (lambda args
+         (ev body (append (map cons fmls args) r)))]
+      [(Call proc actuals)
+        (apply (ev proc r) (map (lambda (x) (ev x r)) actuals))]))
+  
+  (AST? (parse #'(fun (x) x)))
+
+  (define (run x) (ev (parse x) `((- . ,-) (* . ,*) (= . ,=))))
+
+  (run '((fun (f) (f f 10))
+         (fun (f x)
+           (if (= x 0)
+               1
+               (* x (f f (- x 1))))))) ;=> 3628800
+
+|#
+
+(define-syntax define-datatype
+  (lambda (x)
+    (define construct-name
+      (lambda (template-identifier . args)
+        (datum->syntax-object
+          template-identifier
+          (string->symbol
+            (apply string-append
+                   (map (lambda (x)
+                          (if (string? x)
+                              x
+                              (symbol->string (syntax-object->datum x))))
+                        args))))))
+    (define iota
+      (case-lambda
+        [(n) (iota 0 n)]
+        [(i n) (if (= n 0) '() (cons i (iota (+ i 1) (- n 1))))]))
+    (syntax-case x ()
+      [(_ dtname (vname field ...) ...)
+       (and (identifier? #'dtname) (andmap identifier? (syntax->list #'(vname ...))))
+       (with-syntax ([dtname? (construct-name #'dtname #'dtname "?")]
+                     [dtname-case (construct-name #'dtname #'dtname "-case")]
+                     [dtname-variant (construct-name #'dtname #'dtname "-variant")]
+                     [((vname-field ...) ...)
+                      (map (lambda (vname fields)
+                             (map (lambda (field)
+                                    (construct-name #'dtname
+                                      vname "-" field))
+                                  fields))
+                           (syntax->list #'(vname ...))
+                           (map syntax->list (syntax->list #'((field ...) ...))))]
+                     [(make-vname ...)
+                      (map (lambda (x)
+                             (construct-name #'dtname
+                               "make-" x))
+                           (syntax->list #'(vname ...)))]
+                     [(i ...) (iota (length (syntax->list #'(vname ...))))])
+         #'(module (dtname? (dtname-case dtname-variant vname-field ... ...) vname ...)
+             (define-record dtname ((immutable variant)))
+             (module (make-vname vname-field ...)
+               (define-record vname dtname ((immutable field) ...) ()))
+             ...
+             (define-syntax dtname-case
+               (lambda (x)
+                 (define make-clause
+                   (lambda (x)
+                     (syntax-case x (vname ...)
+                       [(vname (field ...) e1 e2 (... ...))
+                        #'((i) (let ([field (vname-field t)] ...)
+                                 e1 e2 (... ...)))]
+                       ...)))
+                 (syntax-case x (else)
+                   [(__ e0
+                        ((v fld (... ...)) e1 e2 (... ...))
+                        (... ...)
+                        (else e3 e4 (... ...)))
+                    (with-syntax ([(clause (... ...))
+                                   (map make-clause
+                                        #'((v (fld (... ...)) e1 e2 (... ...))
+                                           (... ...)))])
+                      #'(let ([t e0])
+                          (case (dtname-variant t)
+                            clause
+                            (... ...)
+                            (else e3 e4 (... ...)))))]
+                   [(__ e0
+                        ((v fld (... ...)) e1 e2 (... ...))
+                        (... ...))
+                    (let f ([ls1 (list #'vname ...)])
+                      (or (null? ls1)
+                          (and (let g ([ls2 (syntax->list #'(v (... ...)))])
+                                 (if (null? ls2)
+                                     (syntax-error x
+                                       (format "unhandled `~s' variant in"
+                                         (syntax-object->datum (car ls1))))
+                                     (or (literal-identifier=? (car ls1) (car ls2))
+                                         (g (cdr ls2)))))
+                               (f (cdr ls1)))))
+                    (with-syntax ([(clause (... ...))
+                                   (map make-clause
+                                        (syntax->list
+                                         #'((v (fld (... ...)) e1 e2 (... ...))
+                                            (... ...))))])
+                      #'(let ([t e0])
+                          (case (dtname-variant t)
+                            clause
+                            (... ...))))])))
+             (define vname
+               (lambda (field ...)
+                 (make-vname i field ...)))
+             ...))])))

package/libraries/chez/callcc/effekt.effekt

@@ -0,0 +1,221 @@
+module effekt
+
+// shift-0 based implementation
+extern include "../common/effekt_primitives.ss"
+// extern include "datatype.ss"
+extern include "seq0.ss"
+extern include "tail0.ss"
+extern include "effekt.ss"
+extern include "../common/effekt_matching.ss"
+
+
+def locally[R] { f: => R }: R = f()
+
+// String ops
+// ==========
+extern pure def infixConcat(s1: String, s2: String): String =
+  "(string-append ${s1} ${s2})"
+
+// TODO implement
+extern pure def show[R](value: R): String =
+  "(show_impl ${value})"
+
+extern io def println[R](r: R): Unit =
+  "(println_impl ${r})"
+
+extern io def error[R](msg: String): R =
+  "(raise ${msg})"
+
+extern io def random(): Double =
+  "(random 1.0)"
+
+// Math ops
+// ========
+extern pure def infixAdd(x: Int, y: Int): Int =
+  "(+ ${x} ${y})"
+
+extern pure def infixMul(x: Int, y: Int): Int =
+  "(* ${x} ${y})"
+
+extern pure def infixDiv(x: Int, y: Int): Int =
+  "(floor (/ ${x} ${y}))"
+
+extern pure def infixSub(x: Int, y: Int): Int =
+  "(- ${x} ${y})"
+
+extern pure def mod(x: Int, y: Int): Int =
+  "(modulo ${x} ${y})"
+
+extern pure def infixAdd(x: Double, y: Double): Double =
+  "(+ ${x} ${y})"
+
+extern pure def infixMul(x: Double, y: Double): Double =
+  "(* ${x} ${y})"
+
+extern pure def infixDiv(x: Double, y: Double): Double =
+  "(/ ${x} ${y})"
+
+extern pure def infixSub(x: Double, y: Double): Double =
+  "(- ${x} ${y})"
+
+extern pure def cos(x: Double): Double =
+  "(cos ${x})"
+
+extern pure def sin(x: Double): Double =
+  "(sin ${x})"
+
+extern pure def atan(x: Double): Double =
+  "(atan ${x})"
+
+extern pure def tan(x: Double): Double =
+  "(tan ${x})"
+
+extern pure def sqrt(x: Double): Double =
+  "(sqrt ${x})"
+
+extern pure def square(x: Double): Double =
+  "(* ${x} ${x})"
+
+extern pure def log(x: Double): Double =
+  "(log ${x})"
+
+extern pure def log1p(x: Double): Double =
+  "(log (+ ${x} 1))"
+
+extern pure def exp(x: Double): Double =
+  "(exp ${x})"
+
+// since we do not have "extern val", yet
+extern pure def _pi(): Double =
+  "(* 4 (atan 1))"
+
+val PI: Double = _pi()
+
+extern pure def toInt(d: Double): Int =
+  "(round ${d})"
+
+extern pure def toDouble(d: Int): Double =
+  "${d}"
+
+def min(n: Int, m: Int): Int =
+    if (n < m) n else m
+
+def max(n: Int, m: Int): Int =
+    if (n > m) n else m
+
+// Comparison ops
+// ==============
+extern pure def infixEq[R](x: R, y: R): Boolean =
+  "(equal_impl ${x} ${y})"
+
+extern pure def infixNeq[R](x: R, y: R): Boolean =
+  "(not (equal_impl ${x} ${y}))"
+
+extern pure def infixLt(x: Int, y: Int): Boolean =
+  "(< ${x} ${y})"
+
+extern pure def infixLte(x: Int, y: Int): Boolean =
+  "(<= ${x} ${y})"
+
+extern pure def infixGt(x: Int, y: Int): Boolean =
+  "(> ${x} ${y})"
+
+extern pure def infixGte(x: Int, y: Int): Boolean =
+  "(>= ${x} ${y})"
+
+extern pure def infixLt(x: Double, y: Double): Boolean =
+  "(< ${x} ${y})"
+
+extern pure def infixLte(x: Double, y: Double): Boolean =
+  "(<= ${x} ${y})"
+
+extern pure def infixGt(x: Double, y: Double): Boolean =
+  "(> ${x} ${y})"
+
+extern pure def infixGte(x: Double, y: Double): Boolean =
+  "(>= ${x} ${y})"
+
+// Boolean ops
+// ===========
+// for now those are considered eager
+extern pure def not(b: Boolean): Boolean =
+  "(not ${b})"
+
+extern pure def infixOr(x: Boolean, y: Boolean): Boolean =
+  "(or ${x} ${y})"
+
+extern pure def infixAnd(x: Boolean, y: Boolean): Boolean =
+  "(and ${x} ${y})"
+
+// Should only be used internally since values in Effekt should not be undefined
+extern pure def isUndefined[A](value: A): Boolean =
+  "(eq? ${value} #f)"
+
+// Pairs
+// =====
+record Tuple2[A, B](first: A, second: B)
+record Tuple3[A, B, C](first: A, second: B, third: C)
+record Tuple4[A, B, C, D](first: A, second: B, third: C, fourth: D)
+record Tuple5[A, B, C, D, E](first: A, second: B, third: C, fourth: D, fifth: E)
+record Tuple6[A, B, C, D, E, F](first: A, second: B, third: C, fourth: D, fifth: E, sixth: F)
+
+// Exceptions
+// ==========
+// a fatal runtime error that cannot be caught
+extern io def panic[R](msg: String): R =
+  "(raise ${msg})"
+
+interface Exception[E] {
+  def raise(exception: E, msg: String): Nothing
+}
+record RuntimeError()
+
+def raise[A](msg: String): A / Exception[RuntimeError] = do raise(RuntimeError(), msg) match {}
+def raise[A, E](exception: E, msg: String): A / Exception[E] = do raise(exception, msg) match {}
+
+// converts exceptions of (static) type E to an uncatchable panic that aborts the program
+def panicOn[E] { prog: => Unit / Exception[E] }: Unit =
+  try { prog() } with Exception[E] { def raise(exception: E, msg: String) = panic(msg) }
+
+// reports exceptions of (static) type E to the console
+def report[E] { prog: => Unit / Exception[E] }: Unit =
+  try { prog() } with Exception[E] { def raise(exception: E, msg: String) = println(msg) }
+
+// ignores exceptions of (static) type E
+// TODO this should be called "ignore" but that name currently clashes with internal pattern matching names on $effekt
+def ignoring[E] { prog: => Unit / Exception[E] }: Unit =
+  try { prog() } with Exception[E] { def raise(exception: E, msg: String) = () }
+
+// Control Flow
+// ============
+interface Control {
+  def break(): Unit
+  def continue(): Unit
+}
+
+def loop { f: () => Unit / Control }: Unit = try {
+  def go(): Unit = { f(); go() }
+  go()
+} with Control {
+  def break() = ()
+  def continue() = loop { f }
+}
+
+/**
+ * Calls provided action repeatedly. `start` is inclusive, `end` is not.
+ */
+def each(start: Int, end: Int) { action: (Int) => Unit / Control } = {
+  var i = start;
+  loop {
+    if (i < end) { val el = i; i = i + 1; action(el) }
+    else { do break() }
+  }
+}
+
+def repeat(n: Int) { action: () => Unit / Control } = each(0, n) { n => action() }
+
+// Benchmarking
+// ============
+// should only be used with pure blocks
+extern control def measure(warmup: Int, iterations: Int) { block: => Unit }: Unit =
+  "(display (measure ${box block} ${warmup} ${iterations}))"

package/libraries/chez/callcc/effekt.ss

@@ -0,0 +1,31 @@
+
+; ;; EXAMPLE
+; ; (handle ([Fail_22 (Fail_109 () resume_120 (Nil_74))])
+; ;       (let ((tmp86_121 ((Fail_109  Fail_22))))
+; ;         (Cons_73  tmp86_121  (Nil_74))))
+; (define-syntax handle
+;   (syntax-rules ()
+;     [(_ ((cap1 (op1 (arg1 ...) k exp ...) ...) ...) body ...)
+;      (let ([P (newPrompt)])
+;         (pushPrompt P
+;           (let ([cap1 (cap1 (define-effect-op P (arg1 ...) k exp ...) ...)] ...)
+;             body ...)))]))
+
+(define-syntax handle
+  (syntax-rules ()
+    [(_ ((cap1 (op1 (arg1 ...) k exp ...) ...) ...) body)
+     (let ([P (newPrompt)])
+        (pushPrompt P
+          (body (cap1 (define-effect-op P (arg1 ...) k exp ...) ...) ...)))]))
+
+(define-syntax define-effect-op
+  (syntax-rules ()
+    [(_ P (arg1 ...) k exp ...)
+     (lambda (arg1 ...)
+       (shift0-at P k exp ...))]))
+
+; state(init) { cell => ... }
+(define (state init body)
+  (with-region (lambda (arena) (body (fresh arena init)))))
+
+(define call/cc/base call/cc)

package/libraries/chez/callcc/seq.ss

@@ -0,0 +1,44 @@
+;;; seq.ss
+;;; Copyright (c) 2005, R. Kent Dybvig, Simon L. Peyton Jones, and Amr Sabry
+
+;;; sequence (Seq) datatype
+
+(define-datatype Seq
+  (EmptyS)
+  (PushP p Seq)
+  ; Box -> BackupState -> Seq -> Seq
+  (PushState b s Seq)
+  (PushSeg k Seq))
+
+(define (splitSeq p seq)
+  (Seq-case seq
+    [(EmptyS) (error 'splitSeq "prompt ~s not found on stack" p)]
+    [(PushP p* sk)
+     (if (not (eq? p p*))
+         (let-values ([(subk sk*) (splitSeq p sk)])
+           (values (PushP p* subk) sk*))
+         (values (EmptyS) sk))]
+    [(PushState b _ sk)
+      (let-values ([(subk sk*) (splitSeq p sk)])
+        (values (PushState b (unbox b) subk) sk*))]
+    [(PushSeg k sk)
+     (let-values ([(subk sk*) (splitSeq p sk)])
+       (values (PushSeg k subk) sk*))]))
+
+(define (appendSeq seq_1 seq_2)
+  (Seq-case seq_1
+    [(EmptyS) seq_2]
+    [(PushP p subk) (PushP p (appendSeq subk seq_2))]
+    [(PushState b s subk)
+      (set-box! b s)
+      (PushState b #f (appendSeq subk seq_2))]
+    [(PushSeg k subk) (PushSeg k (appendSeq subk seq_2))]))
+
+(define-syntax shift0-at
+  (syntax-rules ()
+    [(_ P id exp ...)
+     (withSubCont
+      P
+      (lambda (s)
+         (let ([id (lambda (v) (pushPrompt P (pushSubCont s v)))])
+           exp ...)))]))

package/libraries/chez/callcc/seq0.ss

@@ -0,0 +1,69 @@
+; [ [f1, f2, f3, f4| fields | prompt], [f1, f2, f3, f4| fields | prompt]... ]
+(define-record Stack (
+  [immutable frames]
+  [immutable arena]
+  [immutable prompt]))
+
+(define-record Substack (
+  [immutable frames]
+  [immutable arena]
+  [immutable field-backup]
+  [immutable prompt]))
+
+; MetaCont = (non-empty-list-of Stack)
+; SubCont = (non-empty-list-of Stack)
+
+
+; An Arena is a pointer to a list of cells
+(define (make-arena) (box '()))
+
+(define (fresh arena init)
+  (let* ([cell (box init)]
+         [cells (unbox arena)])
+    (set-box! arena (cons cell cells))
+    cell))
+
+; Backup = List<(Cell, Value)>
+
+; Arena -> Backup
+(define (backup arena)
+  (let ([fields (unbox arena)])
+    (map (lambda (cell) (cons cell (unbox cell))) fields)))
+
+; Backup -> ()
+(define (restore data)
+  (for-each (lambda (cell-data)
+    (set-box! (car cell-data) (cdr cell-data)))
+    data))
+
+; Prompt MetaCont -> SubCont, MetaCont
+(define (splitSeq p seq)
+  (define (split sub s)
+    (if (null? s)
+        (error 'splitSeq "prompt ~s not found on stack" p)
+        (let* ([stack (car s)]
+           [frames (Stack-frames stack)]
+           [arena (Stack-arena stack)]
+           [prompt (Stack-prompt stack)]
+           [rest  (cdr s)])
+          (define sub* (cons (make-Substack frames arena (backup arena) prompt) sub))
+          (if (not (eq? prompt p))
+            (split sub* rest)
+            (values sub* rest)))))
+  (split (list) seq))
+
+
+(define (appendSeq subcont meta)
+  (if (null? subcont)
+    meta
+    (let* ([stack (car subcont)]
+           [frames  (Substack-frames stack)]
+           [arena  (Substack-arena stack)]
+           [fields (Substack-field-backup stack)]
+           [prompt (Substack-prompt stack)]
+           [_ (restore fields)]
+           [rest  (cdr subcont)])
+      (appendSeq rest (cons (make-Stack frames arena prompt) meta)))))
+
+; (define ex (list (make-Stack '(1 2 3) (list (box 1)) 4) (make-Stack '(1 2 3) (list (box 2)) 3) (make-Stack '(1 2 3) (list (box 3)) 2) (make-Stack '(4 5 6) (list (box 4)) 1)))
+; (let-values ([(cont meta) (splitSeq 2 ex)]) (appendSeq cont meta))