├── doc └── intro.md ├── src └── cleff │ ├── protocols.clj │ ├── core.clj │ └── trampoline.clj ├── .gitignore ├── project.clj ├── README.md └── test └── cleff └── core_test.clj /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to cleff 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/great-documentation/what-to-write/) 4 | -------------------------------------------------------------------------------- /src/cleff/protocols.clj: -------------------------------------------------------------------------------- 1 | (ns cleff.protocols) 2 | 3 | (defprotocol IEffect) 4 | 5 | (defprotocol IHandler 6 | (-value [this]) 7 | (-finally [this]) 8 | (-operation [this effect name])) 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | pom.xml 6 | pom.xml.asc 7 | *.jar 8 | *.class 9 | .lein-deps-sum 10 | .lein-failures 11 | .lein-plugins 12 | .lein-repl-history 13 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject cleff "0.1.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.5.1"] 7 | [core.async "0.1.0-SNAPSHOT"]]) 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Cleff 2 | 3 | Cleff provides a framework for extensible handling of computational effects. 4 | 5 | The design is heavily inspired by the Eff programming language. This project 6 | aims to provide a proof of concept implementation of all of the examples in 7 | [Programming with Algebraic Effects and Handlers][1] by Bauer and Pretnar. 8 | 9 | ## Status 10 | 11 | The basics of first-class effects and handlers are working. 12 | 13 | Here's a simple non-deterministic choice effect: 14 | 15 | ```clojure 16 | (defn choose-all [c] 17 | (handler 18 | (value [x] [x]) 19 | c 20 | (decide [] 21 | (concat (continue true) (continue false))))) 22 | 23 | (let [c (choice)] 24 | (handle-with (choose-all c) 25 | (let [x (if (effect c 'decide) 10 20) 26 | y (if (effect c 'decide) 0 5)] 27 | (- x y)))) 28 | ;;=> (10 5 20 15) 29 | ``` 30 | 31 | Lots left to do: 32 | 33 | - Polish up the syntax 34 | - defprotocol-style defeffect 35 | - Subroutines for coping with core.async's lexical IOC 36 | 37 | See the `test/` directory for some more examples. 38 | 39 | ## License 40 | 41 | Copyright © 2013 Brandon Bloom 42 | 43 | Distributed under the Eclipse Public License, the same as Clojure. 44 | 45 | 46 | [1]: http://math.andrej.com/2012/03/08/programming-with-algebraic-effects-and-handlers/ 47 | -------------------------------------------------------------------------------- /test/cleff/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns cleff.core-test 2 | (:require [clojure.test :refer :all] 3 | [cleff.core :refer (instance handler handle handle-with)])) 4 | 5 | (deftest choice-test 6 | 7 | (defn choice [] 8 | (instance)) 9 | 10 | (is (= (let [c (choice)] 11 | (handle [c (decide [] (continue true))] 12 | (let [x (if (effect c 'decide) 10 20) 13 | y (if (effect c 'decide) 0 5)] 14 | (- x y)))) 15 | 10)) 16 | 17 | (is (= (let [c (choice)] 18 | (handle [c (decide [] (continue false))] 19 | (let [x (if (effect c 'decide) 10 20) 20 | y (if (effect c 'decide) 0 5)] 21 | (- x y)))) 22 | 15)) 23 | 24 | (defn choose-all [c] 25 | (handler 26 | (value [x] [x]) 27 | c 28 | (decide [] 29 | (concat (continue true) (continue false))))) 30 | 31 | (is (= (let [c (choice)] 32 | (handle-with (choose-all c) 33 | (let [x (if (effect c 'decide) 10 20) 34 | y (if (effect c 'decide) 0 5)] 35 | (- x y)))) 36 | '(10 5 20 15))) 37 | 38 | (is (= (let [c1 (choice) c2 (choice)] 39 | (handle-with (choose-all c1) 40 | (handle-with (choose-all c2) 41 | (let [x (if (effect c1 'decide) 10 20) 42 | y (if (effect c2 'decide) 0 5)] 43 | (- x y))))) 44 | '((10 5) (20 15)))) 45 | 46 | (is (= (let [c1 (choice) c2 (choice)] 47 | (handle-with (choose-all c2) 48 | (handle-with (choose-all c1) 49 | (let [x (if (effect c2 'decide) 10 20) 50 | y (if (effect c1 'decide) 0 5)] 51 | (- x y))))) 52 | '((10 5) (20 15)))) 53 | 54 | ) 55 | 56 | (deftest exception-test 57 | 58 | (defn exception [] 59 | (instance)) 60 | 61 | (def e (exception)) 62 | 63 | (def optionalize 64 | (handler 65 | (value [x] [:some x]) 66 | e 67 | (raise [_] :none))) 68 | 69 | (is (= (handle-with optionalize 1) 70 | [:some 1])) 71 | 72 | (is (= (handle-with optionalize (effect e 'raise "Disaster!")) 73 | :none)) 74 | 75 | ) 76 | -------------------------------------------------------------------------------- /src/cleff/core.clj: -------------------------------------------------------------------------------- 1 | (ns cleff.core 2 | (:require [cleff.protocols :as proto] 3 | [cleff.trampoline :as trampoline 4 | :refer (operation-form transform-form computation-form)])) 5 | 6 | ;;TODO parameterize with effect type 7 | (deftype Effect [] proto/IEffect) 8 | 9 | (defn instance [] 10 | (Effect.)) 11 | 12 | (defn- handler-fn [bindings-sym env specs] 13 | (letfn [(impl-map [operations] 14 | (into {} (for [[name args & body] operations] 15 | [(list 'quote name) 16 | (operation-form bindings-sym env args body)]))) 17 | (effect-map [specs] 18 | (let [specs* (->> specs (partition-by seq?) (partition 2))] 19 | (into {} (for [[[effect] operations] specs*] 20 | [effect (impl-map operations)]))))] 21 | (let [[transforms effects] (split-with seq? specs) 22 | transforms* (concat '[(value [x] x)] transforms) 23 | transform-map (into {} (for [[name [arg] & body] transforms*] 24 | [name (transform-form bindings-sym env arg body)]))] 25 | `(let [map# ~(effect-map effects)] 26 | (reify proto/IHandler 27 | (proto/-value [this#] 28 | ~(transform-map 'value)) 29 | (proto/-finally [this#] 30 | ~(transform-map 'finally)) 31 | (proto/-operation [this# effect# name#] 32 | (get-in map# [effect# name#]))))))) 33 | 34 | (defn run-with [handler computation] 35 | (trampoline/run handler computation)) 36 | 37 | (defmacro handler [& specs] 38 | (let [bindings-sym (gensym "bindings__")] 39 | `(let [~bindings-sym (clojure.lang.Var/getThreadBindingFrame)] 40 | ~(handler-fn bindings-sym &env specs)))) 41 | 42 | (defmacro handle-with [handler & body] 43 | (let [bindings-sym (gensym "bindings__")] 44 | `(let [~bindings-sym (clojure.lang.Var/getThreadBindingFrame) 45 | computation# ~(computation-form bindings-sym &env body)] 46 | (run-with ~handler computation#)))) 47 | 48 | (defmacro handle [specs & body] 49 | (let [bindings-sym (gensym "bindings__")] 50 | `(let [~bindings-sym (clojure.lang.Var/getThreadBindingFrame) 51 | handler# ~(handler-fn bindings-sym &env specs) 52 | computation# ~(computation-form bindings-sym &env body)] 53 | (run-with handler# computation#)))) 54 | 55 | 56 | ;;; Test Code 57 | 58 | (comment 59 | 60 | (require 'clojure.pprint) 61 | 62 | (defn ppc [form] 63 | (clojure.pprint/write form :dispatch clojure.pprint/code-dispatch)) 64 | 65 | (defn ppme [form] 66 | (-> form macroexpand ppc)) 67 | 68 | (defn choice [] 69 | (instance)) 70 | 71 | (def c (choice)) 72 | 73 | (ppme '(handler)) 74 | 75 | (ppme '(handler (finally [x] x))) 76 | 77 | (ppme '(handler c (decide [] (continue true)))) 78 | 79 | (ppme '(handle [] :foo)) 80 | 81 | (ppme '(handle [(value [x] [x x])] 82 | :foo)) 83 | 84 | ) 85 | -------------------------------------------------------------------------------- /src/cleff/trampoline.clj: -------------------------------------------------------------------------------- 1 | (ns cleff.trampoline 2 | (:require [cleff.protocols :as proto] 3 | [clojure.core.async.impl.ioc-macros :as ioc 4 | :refer (state-machine run-state-machine aget-object aset-all!)]) 5 | (:import [java.util.concurrent.atomic AtomicReferenceArray])) 6 | 7 | 8 | ;;; Utilities 9 | 10 | (defn clone-state [^AtomicReferenceArray state] 11 | (let [n (.length state) 12 | clone (AtomicReferenceArray. n)] 13 | (doseq [i (range n)] 14 | (aset-all! clone i (aget-object state i))) 15 | clone)) 16 | 17 | 18 | ;;; Terminator implementations 19 | 20 | (def TRAMPOLINE-IDX ioc/USER-START-IDX ) 21 | (def COMMUNICATION-IDX (+ ioc/USER-START-IDX 1)) 22 | (def HANDLER-IDX (+ ioc/USER-START-IDX 2)) 23 | (def USER-COUNT 3 ) 24 | 25 | (defn begin [state blk] 26 | (aset-all! state ioc/STATE-IDX blk) 27 | nil) 28 | 29 | (defn continue [state blk value] 30 | (aset-all! state 31 | ioc/STATE-IDX blk 32 | ioc/VALUE-IDX value 33 | TRAMPOLINE-IDX :continue) 34 | nil) 35 | 36 | (defn effect [state blk & args] 37 | (aset-all! state 38 | ioc/STATE-IDX blk 39 | TRAMPOLINE-IDX :effect 40 | COMMUNICATION-IDX args) 41 | nil) 42 | 43 | (defn run-with [state blk & args] 44 | (aset-all! state 45 | ioc/STATE-IDX blk 46 | TRAMPOLINE-IDX :run-with 47 | COMMUNICATION-IDX args) 48 | nil) 49 | 50 | (defn return [state value] 51 | (aset-all! state 52 | ioc/VALUE-IDX value 53 | TRAMPOLINE-IDX :return) 54 | nil) 55 | 56 | 57 | ;;; Coroutine state machines 58 | 59 | (def operation-terminators 60 | {'begin `begin 61 | 'continue `continue 62 | :Return `return}) 63 | 64 | (def transform-terminators 65 | {'begin `begin 66 | :Return `return}) 67 | 68 | (def computation-terminators 69 | {'effect `effect 70 | 'cleff.core/run-with `run-with 71 | :Return `return}) 72 | 73 | (defn handler-form [terminators bindings-sym env args body] 74 | (let [form `(let [~args (~'begin)] ~@body)] 75 | `(let [state# (~(state-machine (list form) USER-COUNT env terminators))] 76 | (aset-all! state# ioc/BINDINGS-IDX ~bindings-sym) 77 | (run-state-machine state#) 78 | state#))) 79 | 80 | (defn operation-form [bindings-sym env args body] 81 | (handler-form operation-terminators bindings-sym env args body)) 82 | 83 | (defn transform-form [bindings-sym env arg body] 84 | (handler-form transform-terminators bindings-sym env arg body)) 85 | 86 | (defn computation-form [bindings-sym env body] 87 | `(let [state# (~(state-machine body USER-COUNT env computation-terminators))] 88 | (aset-all! state# ioc/BINDINGS-IDX ~bindings-sym))) 89 | 90 | 91 | ;;; Interpreter 92 | 93 | (defn push-handler [stack handler] 94 | (let [value-frame (clone-state (proto/-value handler))] 95 | (aset-all! value-frame HANDLER-IDX handler) 96 | (if-let [finally-frame (proto/-finally handler)] 97 | (conj stack finally-frame (clone-state value-frame)) 98 | (conj stack value-frame)))) 99 | 100 | (defmulti step-method (fn [frame stack] 101 | ;(println "step:" (aget-object frame TRAMPOLINE-IDX)) 102 | (aget-object frame TRAMPOLINE-IDX))) 103 | 104 | (defmethod step-method :effect [frame stack] 105 | (let [[effect operation & args] (aget-object frame COMMUNICATION-IDX)] 106 | ;(println "Effect:" (pr-str effect operation args)) 107 | (loop [continuation (list frame) 108 | [frame* & stack*] stack] 109 | (if frame* 110 | (let [frame* (clone-state frame*) 111 | handler (aget-object frame* HANDLER-IDX)] 112 | (if-let [op-frame (and handler (proto/-operation handler effect operation))] 113 | (conj stack* (aset-all! (clone-state op-frame) 114 | ioc/VALUE-IDX args 115 | COMMUNICATION-IDX (conj continuation frame*))) 116 | (recur (conj continuation frame*) stack*))) 117 | (throw (Exception. (str "No handler for " operation " on " effect))))))) 118 | 119 | (defmethod step-method :run-with [frame stack] 120 | (let [[handler computation] (aget-object frame COMMUNICATION-IDX)] 121 | ;(println "Run With:" (pr-str handler computation)) 122 | (-> stack 123 | (conj frame) 124 | (push-handler handler) 125 | (conj computation)))) 126 | 127 | (defmethod step-method :continue [frame stack] 128 | (let [value (aget-object frame ioc/VALUE-IDX) 129 | ;_ (println "Continue:" (pr-str value)) 130 | continuation (aget-object frame COMMUNICATION-IDX) 131 | stack* (into (conj stack frame) (map clone-state continuation))] 132 | (aset-all! (peek stack*) ioc/VALUE-IDX value) 133 | stack*)) 134 | 135 | (defmethod step-method :return [frame stack] 136 | (let [value (aget-object frame ioc/VALUE-IDX)] 137 | ;(println "return:" (pr-str value)) 138 | (if-let [frame* (peek stack)] 139 | (do 140 | (aset-all! frame* ioc/VALUE-IDX value) 141 | stack) 142 | (reduced value)))) 143 | 144 | (defn step [stack] 145 | ;(println "stack depth:" (count stack)) 146 | (let [[frame & stack*] stack] 147 | (run-state-machine frame) 148 | (step-method frame stack*))) 149 | 150 | (defn run [handler computation] 151 | (loop [i 0 stack (-> nil (push-handler handler) (conj computation))] 152 | (when (> i 50) (throw (Exception. "ITERATION LIMIT"))) ;TODO delete me 153 | (if (reduced? stack) 154 | @stack 155 | (recur (inc i) (step stack))))) 156 | --------------------------------------------------------------------------------