@effekt-lang/effekt 0.2.1 → 0.2.2

package/libraries/chez/common/text/regex.effekt

@@ -0,0 +1,33 @@
+module text/regex
+
+import immutable/option
+import immutable/cslist
+import mutable/array
+
+extern include "pregexp.scm"
+
+extern type Regex
+
+record Match(matched: String, index: Int)
+
+extern pure def regex(str: String): Regex =
+  "(pregexp ${str})"
+
+def exec(reg: Regex, str: String): Option[Match] = {
+  val matched = reg.unsafeMatchString(str)
+  if (matched.isUndefined) { None() }
+  else { Some(Match(matched, reg.unsafeMatchIndex(str))) }
+}
+
+extern pure def unsafeMatchIndex(reg: Regex, str: String): Int =
+  "(let ([m (pregexp-match-positions ${reg} ${str})]) (if m (car (car m)) #f))"
+
+// we ignore the captures for now and only return the whole match
+extern pure def unsafeMatchString(reg: Regex, str: String): String =
+  "(let ([m (pregexp-match ${reg} ${str})]) (if m (car m) #f))"
+
+extern pure def split(reg: Regex, str: String): CSList[String] =
+  "(pregexp-split ${reg} ${str})"
+
+def split(str: String, sep: String): Array[String] =
+  sep.regex.split(str).toArray

package/libraries/chez/common/text/string.effekt

@@ -0,0 +1,46 @@
+module text/string
+
+import immutable/option
+
+// def charAt(str: String, index: Int): Option[String] =
+//     str.unsafeCharAt(index).undefinedToOption
+
+extern pure def length(str: String): Int =
+  "(string-length ${str})"
+
+extern pure def repeat(str: String, n: Int): String =
+  "(letrec ([repeat (lambda (${n} acc) (if (<= ${n} 0) acc (repeat (- ${n} 1) (string-append acc ${str}))))]) (repeat ${n} (list->string '())))"
+
+extern pure def unsafeSubstring(str: String, from: Int, to: Int): String =
+  "(substring ${str} ${from} ${to})"
+
+def substring(str: String, from: Int, to: Int): String = {
+  def clamp(lower: Int, x: Int, upper: Int) = max(lower, min(x, upper))
+
+  val len = str.length
+  val clampedTo = clamp(0, to, len)
+  val clampedFrom = clamp(0, from, to)
+
+  str.unsafeSubstring(clampedFrom, clampedTo)
+}
+
+def substring(str: String, from: Int): String =
+  str.substring(from, str.length)
+
+// extern pure def trim(str: String): String =
+//   "str.trim()"
+
+def toInt(str: String): Option[Int] =
+  str.unsafeToInt.undefinedToOption
+
+// extern pure def unsafeCharAt(str: String, n: Int): String =
+//   "str[n]"
+
+// returns #f if not a number
+extern pure def unsafeToInt(str: String): Int =
+  "(string->number ${str})"
+
+// ANSI escape codes
+val ANSI_GREEN = "\033[32m"
+val ANSI_RED = "\033[31m"
+val ANSI_RESET = "\033[0m"

package/libraries/chez/lift/effekt.effekt

@@ -0,0 +1,217 @@
+module effekt
+
+extern include "../common/effekt_primitives.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 =
+  "(delayed (display (measure (lambda () (run ((${box block} here)))) ${warmup} ${iterations})))"

package/libraries/chez/lift/effekt.ss

@@ -0,0 +1,118 @@
+(define-syntax delayed
+  (syntax-rules ()
+    [(_ e ...)
+      (lambda (k) (k
+        (begin e ...)))]))
+
+
+;; EVIDENCE
+
+(define (here x) x)
+
+; (define-syntax lift
+;   (syntax-rules ()
+;     [(_ m)
+;      (lambda (k1)
+;        (lambda (k2)
+;          (m (lambda (a) ((k1 a) k2)))))]))
+
+(define (lift m)
+  (lambda (k1)
+    (lambda (k2)
+      (m (lambda (a) ((k1 a) k2))))))
+
+(define-syntax nested-helper
+  (syntax-rules ()
+    [(_ (ev) acc) (ev acc)]
+    [(_ (ev1 ev2 ...) acc)
+      (nested-helper (ev2 ...) (ev1 acc))]))
+
+(define-syntax nested
+  (syntax-rules ()
+    [(_ ev1 ...) (lambda (m) (nested-helper (ev1 ...) m))]))
+
+
+;; HANDLING
+
+; (define (reset m) (m (lambda (v) (lambda (k) (k v)))))
+
+(define-syntax reset
+  (syntax-rules ()
+    [(_ m)
+     (m (lambda (v) (lambda (k) (k v))))]))
+
+; ;; EXAMPLE
+; ; (handle ([Fail_22 (Fail_109 () resume_120 (Nil_74))])
+; ;       (let ((tmp86_121 ((Fail_109  Fail_22))))
+; ;         (Cons_73  tmp86_121  (Nil_74))))
+
+
+; capabilities first take evidence than require selection!
+(define-syntax handle
+  (syntax-rules ()
+    [(_ (cap1 ...) body)
+     (reset (body lift cap1 ...))]))
+
+
+(define-syntax shift
+  (syntax-rules ()
+    [(_ ev body)
+     (ev body)]))
+
+; capabilities first take evidence than require selection!
+(define-syntax handle-old
+  (syntax-rules ()
+    [(_ ((cap1 (op1 (arg1 ...) kid exp) ...) ...) body)
+     (reset (body lift
+       (cap1 (define-effect-op ev (arg1 ...) kid exp) ...) ...))]))
+
+(define-syntax define-effect-op
+  (syntax-rules ()
+    [(_ ev1 (arg1 ...) kid exp ...)
+     (lambda (ev1 arg1 ...)
+        ; we apply the outer evidence to the body of the operation
+        (ev1 (lambda (resume)
+          ; k itself also gets evidence!
+          (let ([kid (lambda (ev v) (ev (resume v)))])
+            exp ...))))]))
+
+(define (with-region-non-mono body)
+  (define arena (make-arena))
+
+  (define (lift m) (lambda (k)
+    ; on suspend
+    (define fields (backup arena))
+    (m (lambda (a)
+      ; on resume
+      (restore fields)
+      (k a)))))
+
+  (body lift arena))
+
+(define (with-region body)
+  (define arena (make-arena))
+
+  (body arena))
+
+
+; 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))

package/libraries/chez/monadic/effekt.effekt

@@ -0,0 +1,218 @@
+module effekt
+
+extern include "../common/effekt_primitives.ss"
+extern include "seq0.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 =
+  "(delayed (display (measure (lambda () (run (${box block}))) ${warmup} ${iterations})))"

package/libraries/chez/monadic/effekt.ss

@@ -0,0 +1,84 @@
+(define-syntax delayed
+  (syntax-rules ()
+    [(_ e)
+      (lambda (mk) (underflow e mk))]))
+
+; Control = MetaCont -> Step
+
+; a -> Control a
+(define (pure v)
+  (lambda (mk) (underflow v mk)))
+
+; Step a =  (a | Control x), MetaCont x a
+
+; (a | Control a), MetaCont -> a
+(define (trampoline c mk)
+  (if (null? mk) c
+      (call-with-values
+        (lambda () (c mk))
+        trampoline)))
+
+; a, MetaCont -> Step
+(define (underflow v mk)
+  (if (null? mk) (values v mk)
+    (let* ([stack (car mk)]
+           [rest  (cdr mk)]
+           [frames (Stack-frames stack)]
+           [arena (Stack-arena stack)]
+           [prompt (Stack-prompt stack)])
+      (if (null? frames) (underflow v rest)
+          (values ((car frames) v) (cons (make-Stack (cdr frames) arena prompt) rest))))))
+
+; Control, Prompt -> Control
+(define (reset p c)
+  (lambda (mk)
+    (c (cons (make-Stack '() (make-arena) p) mk))))
+
+; Prompt, Body -> Control
+(define (shift p f)
+  (lambda (mk)
+    (let-values ([(k mkrest) (splitSeq p mk)])
+      (let ([cont (lambda (a) (lambda (mk) (underflow a (appendSeq k mk))))])
+      (values (f cont) mkrest)))))
+
+; Frame, MetaCont -> MetaCont
+(define (push-frame f mk)
+  (if (null? mk) (error 'push-frame "Cannot push frame, meta cont ~s is empty" mk)
+    (let ([stack (car mk)]
+          [rest  (cdr mk)])
+      (let ([frames (Stack-frames stack)]
+            [arena (Stack-arena stack)]
+            [prompt (Stack-prompt stack)])
+          (cons (make-Stack (cons f frames) arena prompt) rest)))))
+
+(define-syntax then
+  (syntax-rules ()
+    [(_ m f)
+     (lambda (k) (values m (push-frame f k)))]))
+
+(define toplevel 0)
+
+; Control a -> a
+(define (run c)
+  (trampoline c (cons (make-Stack '() (make-arena) toplevel) '())))
+
+(define newPrompt (lambda () (string #\p)))
+
+(define-syntax handle
+  (syntax-rules ()
+    [(_ ((cap1 (op1 (arg1 ...) kid exp) ...) ...) body)
+     (let ([p (newPrompt)])
+       (reset p (body
+        (cap1 (define-effect-op p (arg1 ...) kid exp) ...)
+        ...)))]))
+
+
+(define-syntax define-effect-op
+  (syntax-rules ()
+    [(_ p (arg1 ...) kid exp ...)
+     (lambda (arg1 ...)
+        (shift p (lambda (kid) exp ...)))]))
+
+; state(init) { cell => ... }
+(define (state init body)
+  (with-region (lambda (arena) (body (fresh arena init)))))