@effekt-lang/effekt 0.2.1 → 0.3.0

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-lang/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.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))

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_primitives.ss

@@ -0,0 +1,105 @@
+(define (show_impl obj)
+  (cond
+    [(number? obj) (show-number obj)]
+    [(string? obj) obj]
+    [(boolean? obj) (if obj "true" "false")]
+    [(char? obj) (show-char obj)]
+    ; [(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)))
+
+(define (show-char c)
+  (string c))
+
+; 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 str)
+  (display str)
+  (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 (timestamp)
+  (let ([t (current-time)])
+    (+ (* (time-second t) 1000000000) (time-nanosecond t))))
+
+(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"))))