[ { "path": ".travis.yml", "content": "dist: xenial\nsudo: true\nlanguage: clojure\nscript:\n - clojure -Aclj-test\n - clojure -Acljs-test\n - clojure -Acljs-test -x planck\ninstall:\n - curl -O https://download.clojure.org/install/linux-install-1.10.1.447.sh\n - chmod +x linux-install-1.10.1.447.sh\n - sudo ./linux-install-1.10.1.447.sh\n - sudo add-apt-repository -y ppa:mfikes/planck\n - sudo apt-get update -y\n - sudo apt-get install -y planck\n" }, { "path": "LICENSE", "content": "Eclipse Public License - v 2.0\n\n THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE\n PUBLIC LICENSE (\"AGREEMENT\"). ANY USE, REPRODUCTION OR DISTRIBUTION\n OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.\n\n1. DEFINITIONS\n\n\"Contribution\" means:\n\n a) in the case of the initial Contributor, the initial content\n Distributed under this Agreement, and\n\n b) in the case of each subsequent Contributor:\n i) changes to the Program, and\n ii) additions to the Program;\n where such changes and/or additions to the Program originate from\n and are Distributed by that particular Contributor. A Contribution\n \"originates\" from a Contributor if it was added to the Program by\n such Contributor itself or anyone acting on such Contributor's behalf.\n Contributions do not include changes or additions to the Program that\n are not Modified Works.\n\n\"Contributor\" means any person or entity that Distributes the Program.\n\n\"Licensed Patents\" mean patent claims licensable by a Contributor which\nare necessarily infringed by the use or sale of its Contribution alone\nor when combined with the Program.\n\n\"Program\" means the Contributions Distributed in accordance with this\nAgreement.\n\n\"Recipient\" means anyone who receives the Program under this Agreement\nor any Secondary License (as applicable), including Contributors.\n\n\"Derivative Works\" shall mean any work, whether in Source Code or other\nform, that is based on (or derived from) the Program and for which the\neditorial revisions, annotations, elaborations, or other modifications\nrepresent, as a whole, an original work of authorship.\n\n\"Modified Works\" shall mean any work in Source Code or other form that\nresults from an addition to, deletion from, or modification of the\ncontents of the Program, including, for purposes of clarity any new file\nin Source Code form that contains any contents of the Program. Modified\nWorks shall not include works that contain only declarations,\ninterfaces, types, classes, structures, or files of the Program solely\nin each case in order to link to, bind by name, or subclass the Program\nor Modified Works thereof.\n\n\"Distribute\" means the acts of a) distributing or b) making available\nin any manner that enables the transfer of a copy.\n\n\"Source Code\" means the form of a Program preferred for making\nmodifications, including but not limited to software source code,\ndocumentation source, and configuration files.\n\n\"Secondary License\" means either the GNU General Public License,\nVersion 2.0, or any later versions of that license, including any\nexceptions or additional permissions as identified by the initial\nContributor.\n\n2. GRANT OF RIGHTS\n\n a) Subject to the terms of this Agreement, each Contributor hereby\n grants Recipient a non-exclusive, worldwide, royalty-free copyright\n license to reproduce, prepare Derivative Works of, publicly display,\n publicly perform, Distribute and sublicense the Contribution of such\n Contributor, if any, and such Derivative Works.\n\n b) Subject to the terms of this Agreement, each Contributor hereby\n grants Recipient a non-exclusive, worldwide, royalty-free patent\n license under Licensed Patents to make, use, sell, offer to sell,\n import and otherwise transfer the Contribution of such Contributor,\n if any, in Source Code or other form. This patent license shall\n apply to the combination of the Contribution and the Program if, at\n the time the Contribution is added by the Contributor, such addition\n of the Contribution causes such combination to be covered by the\n Licensed Patents. The patent license shall not apply to any other\n combinations which include the Contribution. No hardware per se is\n licensed hereunder.\n\n c) Recipient understands that although each Contributor grants the\n licenses to its Contributions set forth herein, no assurances are\n provided by any Contributor that the Program does not infringe the\n patent or other intellectual property rights of any other entity.\n Each Contributor disclaims any liability to Recipient for claims\n brought by any other entity based on infringement of intellectual\n property rights or otherwise. As a condition to exercising the\n rights and licenses granted hereunder, each Recipient hereby\n assumes sole responsibility to secure any other intellectual\n property rights needed, if any. For example, if a third party\n patent license is required to allow Recipient to Distribute the\n Program, it is Recipient's responsibility to acquire that license\n before distributing the Program.\n\n d) Each Contributor represents that to its knowledge it has\n sufficient copyright rights in its Contribution, if any, to grant\n the copyright license set forth in this Agreement.\n\n e) Notwithstanding the terms of any Secondary License, no\n Contributor makes additional grants to any Recipient (other than\n those set forth in this Agreement) as a result of such Recipient's\n receipt of the Program under the terms of a Secondary License\n (if permitted under the terms of Section 3).\n\n3. REQUIREMENTS\n\n3.1 If a Contributor Distributes the Program in any form, then:\n\n a) the Program must also be made available as Source Code, in\n accordance with section 3.2, and the Contributor must accompany\n the Program with a statement that the Source Code for the Program\n is available under this Agreement, and informs Recipients how to\n obtain it in a reasonable manner on or through a medium customarily\n used for software exchange; and\n\n b) the Contributor may Distribute the Program under a license\n different than this Agreement, provided that such license:\n i) effectively disclaims on behalf of all other Contributors all\n warranties and conditions, express and implied, including\n warranties or conditions of title and non-infringement, and\n implied warranties or conditions of merchantability and fitness\n for a particular purpose;\n\n ii) effectively excludes on behalf of all other Contributors all\n liability for damages, including direct, indirect, special,\n incidental and consequential damages, such as lost profits;\n\n iii) does not attempt to limit or alter the recipients' rights\n in the Source Code under section 3.2; and\n\n iv) requires any subsequent distribution of the Program by any\n party to be under a license that satisfies the requirements\n of this section 3.\n\n3.2 When the Program is Distributed as Source Code:\n\n a) it must be made available under this Agreement, or if the\n Program (i) is combined with other material in a separate file or\n files made available under a Secondary License, and (ii) the initial\n Contributor attached to the Source Code the notice described in\n Exhibit A of this Agreement, then the Program may be made available\n under the terms of such Secondary Licenses, and\n\n b) a copy of this Agreement must be included with each copy of\n the Program.\n\n3.3 Contributors may not remove or alter any copyright, patent,\ntrademark, attribution notices, disclaimers of warranty, or limitations\nof liability (\"notices\") contained within the Program from any copy of\nthe Program which they Distribute, provided that Contributors may add\ntheir own appropriate notices.\n\n4. COMMERCIAL DISTRIBUTION\n\nCommercial distributors of software may accept certain responsibilities\nwith respect to end users, business partners and the like. While this\nlicense is intended to facilitate the commercial use of the Program,\nthe Contributor who includes the Program in a commercial product\noffering should do so in a manner which does not create potential\nliability for other Contributors. Therefore, if a Contributor includes\nthe Program in a commercial product offering, such Contributor\n(\"Commercial Contributor\") hereby agrees to defend and indemnify every\nother Contributor (\"Indemnified Contributor\") against any losses,\ndamages and costs (collectively \"Losses\") arising from claims, lawsuits\nand other legal actions brought by a third party against the Indemnified\nContributor to the extent caused by the acts or omissions of such\nCommercial Contributor in connection with its distribution of the Program\nin a commercial product offering. The obligations in this section do not\napply to any claims or Losses relating to any actual or alleged\nintellectual property infringement. In order to qualify, an Indemnified\nContributor must: a) promptly notify the Commercial Contributor in\nwriting of such claim, and b) allow the Commercial Contributor to control,\nand cooperate with the Commercial Contributor in, the defense and any\nrelated settlement negotiations. The Indemnified Contributor may\nparticipate in any such claim at its own expense.\n\nFor example, a Contributor might include the Program in a commercial\nproduct offering, Product X. That Contributor is then a Commercial\nContributor. If that Commercial Contributor then makes performance\nclaims, or offers warranties related to Product X, those performance\nclaims and warranties are such Commercial Contributor's responsibility\nalone. Under this section, the Commercial Contributor would have to\ndefend claims against the other Contributors related to those performance\nclaims and warranties, and if a court requires any other Contributor to\npay any damages as a result, the Commercial Contributor must pay\nthose damages.\n\n5. NO WARRANTY\n\nEXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT\nPERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN \"AS IS\"\nBASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR\nIMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF\nTITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR\nPURPOSE. Each Recipient is solely responsible for determining the\nappropriateness of using and distributing the Program and assumes all\nrisks associated with its exercise of rights under this Agreement,\nincluding but not limited to the risks and costs of program errors,\ncompliance with applicable laws, damage to or loss of data, programs\nor equipment, and unavailability or interruption of operations.\n\n6. DISCLAIMER OF LIABILITY\n\nEXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT\nPERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS\nSHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,\nEXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST\nPROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN\nCONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)\nARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE\nEXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE\nPOSSIBILITY OF SUCH DAMAGES.\n\n7. GENERAL\n\nIf any provision of this Agreement is invalid or unenforceable under\napplicable law, it shall not affect the validity or enforceability of\nthe remainder of the terms of this Agreement, and without further\naction by the parties hereto, such provision shall be reformed to the\nminimum extent necessary to make such provision valid and enforceable.\n\nIf Recipient institutes patent litigation against any entity\n(including a cross-claim or counterclaim in a lawsuit) alleging that the\nProgram itself (excluding combinations of the Program with other software\nor hardware) infringes such Recipient's patent(s), then such Recipient's\nrights granted under Section 2(b) shall terminate as of the date such\nlitigation is filed.\n\nAll Recipient's rights under this Agreement shall terminate if it\nfails to comply with any of the material terms or conditions of this\nAgreement and does not cure such failure in a reasonable period of\ntime after becoming aware of such noncompliance. If all Recipient's\nrights under this Agreement terminate, Recipient agrees to cease use\nand distribution of the Program as soon as reasonably practicable.\nHowever, Recipient's obligations under this Agreement and any licenses\ngranted by Recipient relating to the Program shall continue and survive.\n\nEveryone is permitted to copy and distribute copies of this Agreement,\nbut in order to avoid inconsistency the Agreement is copyrighted and\nmay only be modified in the following manner. The Agreement Steward\nreserves the right to publish new versions (including revisions) of\nthis Agreement from time to time. No one other than the Agreement\nSteward has the right to modify this Agreement. The Eclipse Foundation\nis the initial Agreement Steward. The Eclipse Foundation may assign the\nresponsibility to serve as the Agreement Steward to a suitable separate\nentity. Each new version of the Agreement will be given a distinguishing\nversion number. The Program (including Contributions) may always be\nDistributed subject to the version of the Agreement under which it was\nreceived. In addition, after a new version of the Agreement is published,\nContributor may elect to Distribute the Program (including its\nContributions) under the new version.\n\nExcept as expressly stated in Sections 2(a) and 2(b) above, Recipient\nreceives no rights or licenses to the intellectual property of any\nContributor under this Agreement, whether expressly, by implication,\nestoppel or otherwise. All rights in the Program not expressly granted\nunder this Agreement are reserved. Nothing in this Agreement is intended\nto be enforceable by any entity that is not a Contributor or Recipient.\nNo third-party beneficiary rights are created under this Agreement.\n\nExhibit A - Form of Secondary Licenses Notice\n\n\"This Source Code may also be made available under the following\nSecondary Licenses when the conditions for such availability set forth\nin the Eclipse Public License, v. 2.0 are satisfied: {name license(s),\nversion(s), and exceptions or additional permissions here}.\"\n\n Simply including a copy of this Agreement, including this Exhibit A\n is not sufficient to license the Source Code under Secondary Licenses.\n\n If it is not possible or desirable to put the notice in a particular\n file, then You may include the notice in a location (such as a LICENSE\n file in a relevant directory) where a recipient would be likely to\n look for such a notice.\n\n You may add additional accurate notices of copyright ownership.\n" }, { "path": "README.md", "content": "# cloroutine\n\nA generic, macro-based, stackless coroutine builder for Clojure and ClojureScript.\n\n[![clojars](https://img.shields.io/clojars/v/cloroutine.svg)](https://clojars.org/cloroutine)\n\n[![cljdoc](https://cljdoc.org/badge/cloroutine/cloroutine)](https://cljdoc.org/d/cloroutine/cloroutine/CURRENT)\n\n[![build](https://travis-ci.org/leonoel/cloroutine.svg?branch=master)](https://travis-ci.org/leonoel/cloroutine)\n\n[![license](https://img.shields.io/github/license/leonoel/cloroutine.svg)](LICENSE)\n\n\n## Rationale\n\nCoroutines are syntactic constructs allowing to suspend a computation and resume it later from the point it was suspended. They provide a basis for solutions to various categories of problems. In particular, this strategy has shown notable expressivity improvements in asynchronous programming, sequence generation and data processing.\n\nThis library aims to capture the essence of the inversion-of-control mechanism at work in those solutions. Because applications of this programming style are various and still in active exploration, this library is intentionaly low-level and agnostic wrt concurrency. It provides no execution model, exposing bare unsynchronized mutable objects.\n\nThe reason for this choice is that coroutine-based programming is inherently imperative, and providing thread-safe imperative constructs requires to make opinionated choices impacting performance. `cloroutine` aims to be a simple and generic tool and thus delegates these choices to third-party library designers.\n\n\n## Reference\n\nThis library exposes a single namespace holding a single macro : [`cloroutine.core/cr`](src/cloroutine/core.cljc)\n\n\n## Guides\n\nThe following guides show how to leverage the `cr` macro to implement clojure-flavored versions of various syntactic constructs involving suspendable processes.\n1. [Generators as lazy sequences](doc/01-generators.md)\n2. [Future-based asynchronous processes, aka async/await](doc/02-async-await.md)\n3. [Transducers revisited](doc/03-conduits.md)\n4. [Delimited continuations](doc/04-delimited-continuations.md)\n5. [Monads](doc/05-monads.md)\n" }, { "path": "deps.edn", "content": "{:deps\n {org.clojure/tools.analyzer.jvm {:mvn/version \"1.2.3\"}}\n\n :aliases\n {:dev {:extra-paths [\"test\"]\n :extra-deps {org.clojure/clojurescript {:mvn/version \"1.11.60\"}}}\n\n :clj-test\n {:extra-deps {io.github.cognitect-labs/test-runner\n {:git/tag \"v0.5.0\" :git/sha \"b3fd0d2\"}}\n :extra-paths [\"test\"]\n :main-opts [\"-m\" \"cognitect.test-runner\"]}\n\n :cljs-test\n {:extra-deps {olical/cljs-test-runner {:mvn/version \"3.8.0\"}\n org.clojure/clojurescript {:mvn/version \"1.11.60\"}}\n :extra-paths [\"test\" \"cljs-test-runner-out/gen\"]\n :main-opts [\"-m\" \"cljs-test-runner.main\"]}}}\n" }, { "path": "doc/01-generators.md", "content": "# Generators as lazy sequences\n\nIn this guide, we'll see how coroutines can be leveraged to build immutable, lazy, possibly infinite sequences defined by imperative processes. This technique is available in [various](https://wiki.python.org/moin/Generators) [languages](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Generator) as syntactic constructs known as `generator`s. The idea is to allow the process to suspend its execution to allow the value to be consumed, an operation known as `yield`ing.\n\n```clojure\n(require '[cloroutine.core :refer [cr]])\n```\n\nFirst, let's define a dynamic var to hold the thread-local context keeping track of the generator being evaluated. Each time we run the generator, we bound this var to the tail of the currently generated sequence.\n\n```clojure\n(def ^:dynamic *tail*)\n\n(defn gen-seq [gen]\n (lazy-seq (binding [*tail* (gen-seq gen)] (gen))))\n```\n\n\nWe can now define the `yield` function in charge of the construction of the sequence from a provided value. Because this is a suspending function, we need to define its associated resume function. As we don't need any useful information to process generation further, the resume function will be a `no-op`.\n\n```clojure\n(defn yield [x]\n (cons x *tail*))\n\n(defn no-op [])\n```\n\nWe can now define the `generator` macro, which just calls `gen-seq` with a fresh coroutine wrapping the body, suspending on `yield` and resuming on `nop`. The body is appended with a `nil` to ensure the sequence is over when the generator terminates.\n\n```clojure\n(defmacro generator [& body]\n `(gen-seq (cr {yield no-op} ~@body nil)))\n```\n\nThe generator machinery is done now, let's define some sequences :\n\n```clojure\n(generator\n (yield :a)\n (yield :b)\n (yield :c)) ;; returns (:a :b :c)\n```\n\n```clojure\n(defn my-repeat [x]\n (generator\n (loop []\n (yield x)\n (recur))))\n\n(take 3 (my-repeat 'ho)) ;; returns (ho ho ho)\n```\n\n```clojure\n(defn my-iterate [f x]\n (generator\n (loop [x x]\n (yield x)\n (recur (f x)))))\n\n(take 10 (my-iterate (partial * 2) 1)) ;; returns (1 2 4 8 16 32 64 128 256 512)\n```\n\n```clojure\n(def fibonacci\n (generator\n (loop [prev 0 curr 1]\n (yield curr)\n (recur curr (+ prev curr)))))\n\n(take 10 fibonacci) ;; returns (1 1 2 3 5 8 13 21 34 55)\n```\n" }, { "path": "doc/02-async-await.md", "content": "# Future-based asynchronous processes, aka async/await\n\nIn this guide, we'll implement async/await syntax on top of `java.util.concurrent.CompletableFuture`. Unlike clojure's `future`, java's `CompletableFuture` allows nonblocking composition at the price of additional syntax complexity.\n\nThis syntax burden is familiar to javascript developers and leads to the famous callback-hell when improperly controlled. The async/await syntax, a popular answer to this problem, allows synchronous-looking code to be converted into an asynchronous process.\n\nAs we'll see, coroutines can easily emulate async/await, and this technique can be transposed to any callback-based asynchronous primitive, including javascript promises in clojurescript where blocking is not an option.\n\n```clojure\n(require '[cloroutine.core :refer [cr]])\n(import '(java.util.concurrent CompletableFuture))\n```\n\nFirst, let's define our break points and their associated thread-local context. The asynchronous processes we'll build with `async` blocks are lightweight threads scheduled in user space, we'll refer to them as `*fiber*`s and model them with `java.util.function.BiConsumer`. The `await` function will suspend the fiber and register it on given `CompletableFuture`. When the future resolves, a `*value*` or an `*error*` becomes available to be consumed by `thunk`, the resume function associated with `await`.\n\n```clojure\n(def ^:dynamic *fiber*)\n(def ^:dynamic *value*)\n(def ^:dynamic *error*)\n(defn await [cf] (.whenComplete ^CompletableFuture cf *fiber*))\n(defn thunk [] (if-some [e *error*] (throw e) *value*))\n```\n\nWe can now define async blocks as a macro wrapping its body in a coroutine, passing its result or error to a fresh future. The fresh coroutine is then wrapped in a fiber and immediately started, and the future is returned.\n\n```clojure\n(defmacro async [& body]\n `(let [cf# (CompletableFuture.)\n cr# (cr {await thunk}\n (try (.complete cf# (do ~@body))\n (catch Throwable e#\n (.completeExceptionally cf# e#))))]\n (binding [*fiber* (reify java.util.function.BiConsumer\n (accept [f# v# e#]\n (binding [*fiber* f#\n *value* v#\n *error* e#]\n (cr#))))]\n (cr#)) cf#))\n```\n\nWe can now define `async` blocks and use `await` inside to *park* on a future result.\n\n```clojure\n(def six (async 6)) ;; a future of 6\n(def seven (async (inc (await six)))) ;; a future of 7\n(def failed (async (throw (ex-info \"this is fine.\" {})))) ;; a failed future\n(def recovered (async (try (await failed) (catch Exception e :failed)))) ;; a future of :failed\n```\n" }, { "path": "doc/03-conduits.md", "content": "# Transducers revisited\n\nIn this guide, we'll reimplement [clj-conduit](https://github.com/hypirion/clj-conduit) using `cloroutine`. If you haven't already, I strongly recommend to have a look at the library and the associated [post](http://hypirion.com/musings/transducers-to-conduits-and-back) before going further. A basic understanding of the anatomy of a transducer is required as well.\n\nThe idea of `conduit` is that custom transducers could be much easier to write with a dedicated syntax able to emulate waiting on input. Basically, we want to be able to define a transducer as a block of code in which we would be allowed to use special operators to produce (`yield`) and consume (`await`) values in imperative style.\n\n```clojure\n(require '[cloroutine.core :refer [cr]])\n```\n\nFirst, let's define some dynamic vars to hold thread-local context available during evaluation of conduit blocks.\n* `*acc*` is the accumulator of the reducing process.\n* `*down*` is the downstream reducing function\n* `*input*` is the upstream value currently processed.\n\n```clojure\n(def ^:dynamic *acc*)\n(def ^:dynamic *down*)\n(def ^:dynamic *input*)\n```\n\nWe can now define the functions in charge of I/O in `conduit`s.\n* `yield`ing an output value is a synchronous operation, all we have to do is to reduce the accumulator with given value and check for early termination.\n* `await`ing an input is more tricky because it requires to suspend the process to release control to the transducing context. The function takes as argument a sentinel value to return in case of end-of-stream, when the process requires a finalization step. Otherwise the function can be called with zero argument and the process will be resumed only on available input.\n* `input` is the resume function associated with `await`, its sole job is to retrieve input value from context.\n\n```clojure\n(defn yield [x]\n (not (reduced? (set! *acc* (*down* *acc* x)))))\n\n(defn await\n ([] (await ::done))\n ([eos] eos))\n\n(defn input []\n *input*)\n```\n\nNow, let's define the function `conduit-xf` building the transducer itself. The conduit process is wrapped in a coroutine, itself wrapped in a constructor function. The coroutine is instanciated on transducing context initialization, along with a mutable box to keep track of the end-of-stream sentinel value between two successive steps.\n\n```clojure\n(defn conduit-xf [ctor]\n (fn [down]\n (let [cor (ctor)\n eos (volatile! (cor))]\n (fn rf\n ([]\n (down))\n ([acc]\n (down (case @eos\n ::done acc\n (rf acc @eos))))\n ([acc x]\n (binding [*acc* acc\n *down* down\n *input* x]\n (vreset! eos (cor))\n *acc*))))))\n```\n\nThe `conduit` macro now simply consists of wrapping a body in a coroutine, ensuring early termination of the reduction process when done.\n```clojure\n(defmacro conduit [& body]\n `(conduit-xf\n #(cr {await input}\n ~@body (set! *acc* (ensure-reduced *acc*)) ::done)))\n```\n\nAdditionally, we can define syntactic sugar on top of `await`, allowing to branch on end-of-stream without having to provide and test against a sentinel.\n```clojure\n(defmacro if-let-await [sym then else]\n `(let [x# (await ::over)]\n (case x#\n ::over ~else\n (let [~sym x#] ~then))))\n```\n\nAs an example of usage, here are the reimplementations of clojure.core's transducers, stolen from [clj-conduit](https://github.com/hyPiRion/clj-conduit/wiki/clojure.core-ports).\n\n```clojure\n(defn mapping [f]\n (conduit\n (while true\n (yield (f (await))))))\n\n(defn mapping-indexed [f]\n (conduit\n (loop [i 0]\n (yield (f i (await)))\n (recur (inc i)))))\n\n(defn filtering [pred]\n (conduit\n (while true\n (let [val (await)]\n (when (pred val)\n (yield val))))))\n\n(defn taking-while [pred]\n (conduit\n (loop []\n (let [val (await)]\n (when (pred val)\n (yield val)\n (recur))))))\n\n(defn taking [n]\n (conduit\n (dotimes [_ n]\n (yield (await)))))\n\n(defn taking-nth [n]\n (conduit\n (while true\n (yield (await))\n (dotimes [_ (- n 1)]\n (await)))))\n\n(defn dropping [n]\n (conduit\n (dotimes [_ n]\n (await))\n (while true\n (yield (await)))))\n\n(defn dropping-while [pred]\n (conduit\n (loop [v (await)]\n (if (pred v)\n (recur (await))\n (yield v)))\n (while true\n (yield (await)))))\n\n(def catting\n (conduit\n (while true\n (doseq [val (await)]\n (yield val)))))\n\n(defn mapcatting [f]\n (conduit\n (while true\n (doseq [val (f (await))]\n (yield val)))))\n\n(def deduping\n (conduit\n (loop [old ::none]\n (let [new (await)]\n (when-not (= old new)\n (yield new))\n (recur new)))))\n\n(defn replacing [smap]\n (conduit\n (while true\n (let [val (await)]\n (yield (get smap val val))))))\n\n(defn keeping [f]\n (conduit\n (while true\n (let [v (f (await))]\n (when-not (nil? v)\n (yield v))))))\n\n(defn keeping-indexed [f]\n (conduit\n (loop [i 0]\n (let [v (f i (await))]\n (when-not (nil? v)\n (yield v)))\n (recur (inc i)))))\n\n(def distincting\n (conduit\n (loop [seen #{}]\n (let [val (await)]\n (if-not (contains? seen val)\n (do (yield val)\n (recur (conj seen val)))\n (recur seen))))))\n\n(defn random-sampling [prob]\n (conduit\n (while true\n (let [val (await)]\n (when (< (rand) prob)\n (yield val))))))\n\n(defn interposing [sep]\n (conduit\n (yield (await))\n (while true\n (let [val (await)]\n (yield sep)\n (yield val)))))\n\n(defn partitioning-all [n]\n (conduit\n (loop [vs [(await)]]\n (if (= n (count vs))\n (do (yield vs)\n (recur [(await)]))\n (if-let-await v\n (recur (conj vs v))\n (yield vs))))))\n\n(defn partitioning-by [f]\n (conduit\n (let [first-val (await)]\n (loop [vs [first-val]\n to-cmp (f first-val)]\n (if-let-await v\n (let [new-to-cmp (f v)]\n (if (= to-cmp new-to-cmp)\n (recur (conj vs v) to-cmp)\n (do (yield vs)\n (recur [v] new-to-cmp))))\n (yield vs))))))\n```\n" }, { "path": "doc/04-delimited-continuations.md", "content": "# Delimited continuations\n\nIn this guide, we'll implement a clojure version of scheme's `shift`/`reset` control flow operators. The idea is to be able to define a block of code inside which we could arbitrarily break current execution state, deferring evaluation of the rest of the block, and have this continuation reified as a plain function.\n\nIf you're familiar with scheme's operators, ours will be slightly different :\n* Instead of taking a binding and a body, our `shift` will take a function along with optional arguments and call that function with the continuation as first argument, followed by optional arguments. This style is just more idiomatic clojure, althought there wouldn't be any technical limitation to do it the scheme way.\n* Unlike scheme, our host platform provides very limited stack manipulation features so we can't shift/reset across stack frames. That's why our solution relies on static, macro-based, lexical techniques, preventing us to `shift` outside of the synchronous boundaries of a `reset` block.\n\nWhat we want is to write code like this :\n```clojure\n(* 2 (reset (+ 1 (shift function with some args))))\n```\n\nAnd be it equivalent to this :\n```clojure\n(* 2 (function #(+ 1 %) with some args))\n```\n\n`reset` will be a macro building a coroutine from its body, and immediately running it. The coroutine will be suspended on `shift`. When called, it must capture the reference of the coroutine currently running, wrap it in a continuation, pass it to given function and return the result. Because the continuation is exposed to the wild and can be called an arbitrary number of times in an arbitrary number of threads, it must first clone the captured coroutine, then provide given argument to the dynamic context so that the resume function can access it, and finally resume the freshly cloned coroutine.\n```clojure\n(require '[cloroutine.core :refer [cr]])\n```\n\nOur dynamic context will hold the coroutine currently running in `*coroutine*`, and the argument passed to the continuation in `*result*`.\n```clojure\n(def ^:dynamic *coroutine*)\n(def ^:dynamic *result*)\n```\n\n`run` will be used to start/resume the coroutine, binding it to the dynamic context.\n```clojure\n(defn run [c]\n (binding [*coroutine* c] (c)))\n```\n\n`fork` will be called on continuation. It binds its argument to the dynamic context, then clones the parent coroutine and resumes it.\n```clojure\n(defn fork [c x]\n (binding [*result* x] (c run)))\n```\n\n`shift` captures the coroutine currently running, builds a continuation from it, passes it to given function and returns the result.\n```clojure\n(defn shift [f & args]\n (apply f (partial fork *coroutine*) args))\n```\n\n`thunk` will provide the continuation argument on coroutine resume, defining the result of `shift` in the `reset` body.\n```clojure\n(defn thunk [] *result*)\n```\n\n`reset` builds the coroutine and immediately runs it.\n```clojure\n(defmacro reset [& body]\n `(run (cr {shift thunk} ~@body)))\n```\n\nAnd we're done.\n```clojure\n(reset (* 2 (shift map (range 3))))\n#_=> (0 2 4)\n```\n" }, { "path": "doc/05-monads.md", "content": "# Monads\n\nA monad refers to a category of values associated with a pair of functions `[unit bind]` such that :\n* `(unit x)` returns a member of this category given any value `x`\n* `(bind f m)` returns a member of this category given any other member `m` of this category and a function `f` taking a single argument and returning a member of this category.\n* `(bind f (unit x))` is equivalent to `(f x)`\n* `(bind unit m)` is equivalent to `m`\n* `(->> m (bind f) (bind g))` is equivalent to `(bind #(bind g (f %)) m)`\n\nSome monads :\n```clojure\n;; clojure sequences are monadic out of the box.\n(def seqable-monad [list mapcat])\n\n;; a monad short-circuiting computation on nil.\n(def nilable-monad [identity (fn [f x] (when (some? x) (f x)))])\n```\n\nThe monad abstraction allows to build very flexible syntactic constructs to express sequential logic. For instance, let's see how we could generalize clojure's `for` notation (the simple part, at least) to any monad and have a notation similar to haskell's `do` (`do` has a different meaning in clojure so it'll be `mlet`, for monadic let).\n\n```clojure\n(defmacro mlet [monad bindings & body]\n (if-some [[s m & bindings] (seq bindings)]\n `((second ~monad) (fn [~s] (mlet ~monad ~bindings ~@body)) ~m)\n `((first ~monad) (do ~@body))))\n\n(mlet seqable-monad\n [x [1 2]\n y [3 4]]\n (* x y))\n#_=> (3 4 6 8)\n\n(mlet nilable-monad\n [x 1\n y nil\n z 2]\n (* x y z))\n#_=> nil\n```\n\nThis may be an improvement over plain old lambda declaration, but we can do better. You may have detected a smell in the code we had to write : usually, when a `let` binding is used only one time, it can be inlined where it's used. This leads to more concise code and reduces the burden of naming, but `mlet` forbids this. A better syntax would be to have an `mdo` operator, taking a monad definition and a body of expressions, and returning the evaluation of expressions in the context of that monad. Inside the body, we could use a special operator (say, `>>=`) to indicate that the rest of the evaluation must be performed against given monadic value.\n\n```clojure\n(mdo seqable-monad\n (* (>>= [1 2]) (>>= [3 4])))\n#_=> (3 4 6 8)\n\n(mdo nilable-monad\n (* (>>= 1) (>>= nil) (>>= 2)))\n#_=> nil\n```\n\nThis trick turns out to be very close to delimited continuations, and can be implemented with clonable coroutines as well. `mdo` will be a macro building a coroutine from its body, passing the final result to `unit`, and immediately running it. The coroutine will be suspended on `>>=`. When called, it will build a continuation from the coroutine currently running, pass it to `bind` along with provided monadic value and return the result.\n```clojure\n(require '[cloroutine.core :refer [cr]])\n```\n\nOur dynamic context will hold the coroutine currently running in `*coroutine*`, the monad's bind function in `*bind*`, and the value passed to the continuation in `*result*`.\n```clojure\n(def ^:dynamic *coroutine*)\n(def ^:dynamic *bind*)\n(def ^:dynamic *result*)\n```\n\n`run` will be used to start/resume the coroutine, binding it to the dynamic context along with the monad's bind function.\n```clojure\n(defn run [c b]\n (binding [*coroutine* c\n *bind* b] (c)))\n```\n\n`fork` will be called on continuation. It binds its argument to the dynamic context, then clone the parent coroutine and resumes it.\n```clojure\n(defn fork [c b r]\n (binding [*result* r]\n (c run b)))\n```\n\n`>>=` wraps the coroutine currently running and the monad's bind function in a continuation, passes it to the bind function along with provided monadic value and returns transformed monadic value.\n```clojure\n(defn >>= [m]\n (*bind* (partial fork *coroutine* *bind*) m))\n```\n\n`=<<` will be the coroutine resume function, returning the argument passed to the continuation from dynamic context.\n```clojure\n(defn =<< [] *result*)\n```\n\n`mdo` builds the coroutine and immediately runs it.\n```clojure\n(defmacro mdo [monad & body]\n `(run (cr {>>= =<<} ((first ~monad) (do ~@body))) (second ~monad)))\n```\n\nAs a final example, let's define the state monad and reimplement the parsing game from [haskell documentation](https://wiki.haskell.org/State_Monad).\n\n```clojure\n(def state-monad\n [(fn [x] (fn [s] [x s]))\n (fn [f m] (fn [s] (let [[x s] (m s)] ((f x) s))))])\n\n(defn state-eval [m s]\n (first (m s)))\n\n(defn state-get [s]\n [s s])\n\n(defn state-set [s]\n (fn [_] [nil s]))\n\n(defn game [input]\n (mdo state-monad\n (let [[on score] (>>= state-get)]\n (if-some [[x & xs] (seq input)]\n (do (case x\n \\a (when on (>>= (state-set [on (inc score)])))\n \\b (when on (>>= (state-set [on (dec score)])))\n \\c (>>= (state-set [(not on) score])))\n (>>= (game xs))) score))))\n\n(defn play [input]\n (state-eval (game input) [false 0]))\n\n(play \"abcaaacbbcabbab\")\n#_=> 2\n```\n" }, { "path": "src/cloroutine/core.cljc", "content": "(ns cloroutine.core (:require [cloroutine.impl :as i]))\n\n(defmacro\n ^{:arglists '([breaks & body]) :doc \"\nBuilds a coroutine evaluating body (in an implicit do), suspending evaluation at\ncall sites defined in the breaks map. The breaks map associates suspend vars to\nresume vars, both given as fully-qualified symbols.\n\nA coroutine is a stateful zero-arity function. Calling a coroutine in initial or\nsuspended state starts or resumes evaluation and returns the result of the next\nencountered suspend var call or final body expression.\n\nAfter calling a suspend var, the coroutine is in suspended state. A subsequent\ncoroutine call will resume body evaluation, the result of the suspend var call\nbeing substituted with the result of calling its associated resume var with zero\nargument.\n\nAfter reaching final body expression, or getting an uncaught exception, the\ncoroutine is in terminated state. Subsequent calls have undefined behavior.\n\nThe state of a coroutine is not synchronized, each call to a suspend var is\nexpected to happen-before its associated coroutine resume call.\n\nSuspend and resume vars are guaranteed to be called synchronously in the thread\ncalling the coroutine. For this reason, the cr macro will ignore breaking vars\nin code able to escape synchronous execution context. This includes function\nbodies and custom type methods.\n\nCalling the non-zero arity of a coroutine will clone the coroutine and pass the\ncopy to the function provided as first argument, and return the result. Other\narguments are passed to the function as-is.\n\"} cr [breaks & body]\n (i/compile (gensym \"cr\") breaks &env (cons `do body)))\n" }, { "path": "src/cloroutine/impl/analyze_clj.clj", "content": "(ns cloroutine.impl.analyze-clj\n (:require [clojure.tools.analyzer.jvm :as clj])\n (:import (clojure.lang Compiler$LocalBinding)))\n\n(defn analyze [env form]\n (binding [clj/run-passes clj/scheduled-default-passes]\n (->> env\n (into {} (map (fn [[symbol binding]]\n [symbol (or (when (instance? Compiler$LocalBinding binding)\n (let [binding ^Compiler$LocalBinding binding]\n {:op :local\n :tag (when (.hasJavaClass binding)\n (some-> binding (.getJavaClass)))\n :form symbol\n :name symbol}))\n binding)])))\n (update (clj/empty-env) :locals merge)\n (clj/analyze form))))\n" }, { "path": "src/cloroutine/impl/analyze_cljs.cljc", "content": "(ns cloroutine.impl.analyze-cljs\n (:require [cljs.analyzer]\n [cljs.env]))\n\n(defn analyze [env form]\n (binding [cljs.env/*compiler* (or cljs.env/*compiler*\n (cljs.env/default-compiler-env))]\n (cljs.analyzer/analyze env form nil nil)))\n" }, { "path": "src/cloroutine/impl.cljc", "content": "(ns ^:no-doc cloroutine.impl\n (:refer-clojure :exclude [compile])\n (:require #?(:cljs [cloroutine.impl.analyze-cljs :as impl]\n :clj [cloroutine.impl.analyze-clj :as impl]))\n #?(:cljs (:require-macros [cloroutine.impl :refer [safe hint]])\n :clj (:import (clojure.lang IObj)\n (java.lang.reflect Field Modifier)\n (sun.misc Unsafe))))\n\n(def unsafe\n #?(:clj\n (some (fn [^Field f]\n (when (Modifier/isStatic (.getModifiers f))\n (when (= Unsafe (.getType f))\n (.setAccessible f true)\n (.get f nil))))\n (.getDeclaredFields Unsafe))\n :default nil))\n\n(def box->prim\n '{java.lang.Boolean boolean\n java.lang.Byte byte\n java.lang.Character char\n java.lang.Short short\n java.lang.Integer int\n java.lang.Long long\n java.lang.Float float\n java.lang.Double double})\n\n(def prim->box\n (reduce-kv #(assoc %1 %3 %2) {} box->prim))\n\n(defn class->symbol [c]\n #?(:clj\n (when (instance? Class c)\n (let [s (symbol (.getName ^Class c))]\n (get box->prim s s)))))\n\n(defn tag->symbol [c]\n (or\n (when (symbol? c) c)\n (class->symbol c)))\n\n(defn with-tag [form tag]\n (if #?(:clj (instance? IObj form) :cljs (satisfies? IMeta form))\n (with-meta form (assoc (meta form) :tag tag)) form))\n\n(defn var-name [ast]\n (when (= :var (:op ast))\n (or (when-some [v (:info ast)]\n (:name v))\n (when-some [v (:meta ast)]\n (symbol (str (:ns v)) (name (:name v)))))))\n\n(defmacro hint [to from form]\n (if (:js-globals &env)\n (with-tag form to)\n (if (prim->box to)\n (list to form)\n (if-some [from-box (prim->box from)]\n (with-tag (list (symbol (str from-box \"/valueOf\")) form) to)\n (with-tag form to)))))\n\n(defmacro safe [[error success] failure & finally]\n `(try ~success\n (catch ~(if (:js-globals &env) :default `Throwable) ~error ~failure)\n ~@(when finally (list `(finally ~@finally)))))\n\n(defn coroutine [^objects state]\n (fn\n ([]\n (let [result ((aget state 0) state)]\n (if (identical? result state)\n (recur) result)))\n ([f] (f (coroutine (aclone state))))\n ([f a] (f (coroutine (aclone state)) a))\n ([f a b] (f (coroutine (aclone state)) a b))\n ([f a b c] (f (coroutine (aclone state)) a b c))\n ([f a b c & ds] (apply f (coroutine (aclone state)) a b c ds))))\n\n(defn sym [& args]\n (symbol (apply str (interpose \"-\" args))))\n\n(def conj-vec (fnil conj []))\n(def conj-set (fnil conj #{}))\n(def into-set (fnil into #{}))\n\n(defn- cljs-provided? []\n #?(:cljs true\n :clj (boolean (requiring-resolve 'cljs.env/default-compiler-env))))\n\n(defn analyze [env form]\n (if (and (:js-globals env) (cljs-provided?))\n #?(:cljs (impl/analyze env form)\n :clj ((requiring-resolve 'cloroutine.impl.analyze-cljs/analyze) env form))\n #?(:cljs (throw (ex-info \"Can't target JVM from clojurescript.\" {}))\n :clj (impl/analyze env form))))\n\n(defn coerce-js-literal-key [k]\n (or\n (and (string? k) k)\n (and (keyword? k) (nil? (namespace k)) (name k))\n (throw (ex-info (str \"Invalid JS literal key - \" k) {:key k}))))\n\n(def ssa\n (letfn [(emit-apply [args meta & prefixes]\n (with-meta `(~@prefixes ~@args) meta))\n (emit-member-access [[inst & args] meta member]\n (with-meta `(. ~inst ~member ~@args) meta))\n (emit-member-assign [[inst val] meta member]\n (with-meta `(set! (. ~inst ~member) ~val) meta))\n (emit-case [[test default & thens] meta tests]\n (with-meta `(case ~test ~@(interleave tests thens) ~default) meta))\n (emit-vec [args meta]\n (with-meta (vec args) meta))\n (emit-set [args meta]\n (with-meta (set args) meta))\n (emit-map [args meta]\n (with-meta (apply hash-map args) meta))\n (emit-js-object [args meta keys]\n (with-meta (cons 'cljs.core/js-obj (interleave keys args)) meta))\n (emit-js-array [args meta]\n (with-meta (cons 'cljs.core/array args) meta))\n (emit-place [{:keys [places]\n :as ssa}\n tag place]\n `(hint ~tag\n ~(when (contains? places place)\n (-> places place :tag))\n ~place))\n (instance [ast]\n (or (:instance ast) (:target ast)))\n (field [ast]\n (symbol (str \"-\" (or (:field ast) (:m-or-f ast)))))\n (case-tests [{:keys [tests nodes]}]\n (if tests\n (map (comp list :form) tests)\n (map (comp (partial map :form) :tests) nodes)))\n (case-thens [{:keys [thens nodes]}]\n (if thens\n (map :then thens)\n (map (comp :then :then) nodes)))\n (try-handler [ast sym]\n (if (:name ast)\n (:catch ast)\n ((fn rec [catch catches]\n (if-some [[{{class :val} :class :keys [local body]} & catches] catches]\n (let [then {:op :let\n :bindings [(assoc local :init {:op :local :name sym})]\n :body body}]\n (case class\n java.lang.Throwable then\n {:op :if\n :test {:op :instance?\n :class class\n :target {:op :local :name sym}}\n :then then\n :else (rec catch catches)}))\n catch))\n {:op :throw\n :exception {:op :local :name sym}}\n (seq (:catches ast)))))\n (constructor [{:keys [class]}]\n (or (:val class) (:name class)))\n (ast-meta [ast]\n (select-keys (:env ast) [:file :column :line]))\n (function [ast]\n (or (:f ast) (:fn ast)))\n (js-template [ast]\n (or (:code ast) (apply str (interpose \"~{}\" (:segs ast)))))\n (restore [m p & ks]\n (reduce (fn [m k]\n (if-some [x (p k)]\n (assoc m k x)\n (dissoc m k))) m ks))\n (current-block [ssa]\n (sym (:prefix ssa) 'block (-> ssa :blocks count dec)))\n (with-place [{:keys [places]\n :as ssa}\n place]\n (let [block (current-block ssa)]\n (if (or (not (contains? places place))\n (= block (-> places place :block)))\n ssa (update-in ssa [:blocks block :read] conj-set place))))\n (collect [ssa rf asts f & args]\n (loop [ssa (assoc ssa :result [] :tag [])\n asts (seq asts)]\n (if-some [[ast & asts] asts]\n (let [res (:result ssa)\n tag (:tag ssa)\n ssa (rf ssa ast)]\n (if (contains? ssa :result)\n (recur (-> ssa\n (update :result (partial conj res))\n (update :tag (partial conj tag))) asts) ssa))\n (apply f ssa args))))\n (add-closing-method [ssa {:keys [variadic? params body]}]\n (-> ssa\n (update :shadow into-set (map :name) params)\n (add-closing body)\n (restore ssa :shadow)\n (update :result (partial list (if variadic?\n (-> (into [] (map :name) (pop params))\n (conj '& (-> params peek :name)))\n (into [] (map :name) params))))))\n (add-closing [ssa ast]\n (let [met (ast-meta ast)]\n (case (:op ast)\n\n :with-meta\n (let [ssa (add-closing ssa (:expr ast))]\n (update ssa :result (partial list `with-meta) (:form (:meta ast))))\n\n (:const :var :js-var :quote :the-var :static-field)\n (assoc ssa :result (:form ast))\n\n :local\n (let [l (:name ast)\n s (get-in ssa [:shadow l])\n p (get-in ssa [:locals l])]\n (if s\n (assoc ssa :result `(hint ~(-> ast :tag tag->symbol) ~(:tag met) ~s))\n (if p\n (-> ssa\n (with-place p)\n (assoc :result (emit-place ssa (:tag met) p)))\n (assoc ssa :result `(hint ~(-> ast :tag tag->symbol) ~(:tag met) ~l)))))\n\n (:let :loop)\n (let [previous ssa\n {:keys [op bindings body]} ast\n {:as ssa bindings :result}\n (reduce (fn [{:as ssa bindings :result} {:keys [name init]}]\n (let [{:as ssa init :result} (add-closing ssa init)]\n (-> ssa\n (assoc :result (conj bindings name init))\n (update :shadow conj-set name))))\n (assoc ssa :result []) bindings)\n {:as ssa body :result}\n (add-closing ssa body)]\n (-> ssa\n (restore previous :shadow)\n (assoc :result (emit-apply [bindings body] met (case op :let `let* :loop `loop*)))))\n\n (:invoke :prim-invoke)\n (collect ssa add-closing (cons (function ast) (:args ast)) update :result emit-apply met)\n\n :keyword-invoke\n (collect ssa add-closing (list (:target ast)) update :result emit-apply met (-> ast :keyword :form))\n\n :protocol-invoke\n (collect ssa add-closing (list* (:protocol-fn ast) (:target ast) (:args ast)) update :result emit-apply met)\n\n :instance?\n (collect ssa add-closing (list (:target ast)) update :result emit-apply met `instance? (:class ast))\n\n (:instance-call :host-call)\n (collect ssa add-closing (cons (instance ast) (:args ast)) update :result emit-member-access met (:method ast))\n\n (:instance-field :host-field :host-interop)\n (collect ssa add-closing (cons (instance ast) (:args ast)) update :result emit-member-access met (field ast))\n\n :static-call\n (collect ssa add-closing (:args ast) update :result emit-apply met '. (:class ast) (:method ast))\n\n :new\n (collect ssa add-closing (:args ast) update :result emit-apply met 'new (constructor ast))\n\n :set!\n (collect ssa add-closing [(:target ast) (:val ast)] update :result emit-apply met `set!)\n\n :def\n (collect ssa add-closing (list (:init ast)) update :result emit-apply met `def (-> ast :var :form))\n\n :js\n (collect ssa add-closing (:args ast) update :result emit-apply met 'js* (js-template ast))\n\n :js-array\n (collect ssa add-closing (:items ast) update :result emit-js-array met)\n\n :js-object\n (collect ssa add-closing (:vals ast) update :result emit-js-object met (map coerce-js-literal-key (:keys ast)))\n\n :vector\n (collect ssa add-closing (:items ast) update :result emit-vec met)\n\n :set\n (collect ssa add-closing (:items ast) update :result emit-set met)\n\n :map\n (collect ssa add-closing (interleave (:keys ast) (:vals ast)) update :result emit-map met)\n\n :recur\n (collect ssa add-closing (:exprs ast) update :result emit-apply met `recur)\n\n :do\n (collect ssa add-closing (conj (vec (:statements ast)) (:ret ast)) update :result emit-apply met `do)\n\n :if\n (collect ssa add-closing [(:test ast) (:then ast) (:else ast)] update :result emit-apply met `if)\n\n :case\n (collect ssa add-closing (list* (:test ast) (:default ast) (case-thens ast))\n update :result emit-case met (case-tests ast))\n\n :throw\n (collect ssa add-closing (list (:exception ast)) update :result emit-apply met `throw)\n\n :monitor-enter\n (collect ssa add-closing (list (:target ast)) update :result emit-apply met 'monitor-enter)\n\n :monitor-exit\n (collect ssa add-closing (list (:target ast)) update :result emit-apply met 'monitor-exit)\n\n :fn\n (let [local (:local ast)\n cljs-crap (when-some [t (-> ast :methods first :type)] {:cljs.analyzer/type t})]\n (-> (reduce (fn [ssa method]\n (-> ssa\n (add-closing-method method)\n (update :result (partial conj-vec (:result ssa)))))\n (-> (if local (update ssa :shadow conj-set (:name local)) ssa)\n (dissoc :result)) (:methods ast))\n (restore ssa :shadow)\n (update :result (if local (partial cons (:name local)) identity))\n (update :result emit-apply (merge met cljs-crap) 'fn*)))\n\n :reify\n (-> (reduce (fn [ssa method]\n (-> ssa\n (add-closing-method (update method :params (partial into [(:this method)])))\n (update :result (partial cons (:name method)))\n (update :result (partial conj (:result ssa)))))\n (assoc ssa :result []) (:methods ast))\n (update :result (->> (-> (:interfaces ast) #?(:clj (disj IObj)))\n (map tag->symbol)\n (apply partial list* `reify))))\n\n :deftype\n (let [{:keys [t fields pmasks protocols body]} ast]\n (-> ssa\n (update :shadow into-set fields)\n (add-closing body)\n (restore ssa :shadow)\n (update :result (partial list `deftype* (vary-meta t assoc :protocols protocols) fields pmasks))))\n\n :letfn\n (let [prev ssa\n {:keys [bindings body]} ast\n {:as ssa bindings :result}\n (reduce (fn [{:as ssa bindings :result} {:keys [init name]}]\n (-> ssa\n (add-closing (dissoc init :local))\n (update :result with-meta nil)\n (update :result (partial conj-vec bindings name))))\n (-> ssa\n (assoc :result [])\n (update :shadow into-set (map :name) bindings)) bindings)]\n (-> ssa\n (add-closing body)\n (restore prev :shadow)\n (update :result list)\n (update :result emit-apply met 'letfn* bindings)))\n\n :try\n (let [handled (or (:name ast) (sym (:prefix ssa) 'exception))\n {:as ssa body :result} (add-closing ssa (:body ast))\n {:as ssa handler :result} (-> ssa\n (update :shadow conj-set handled)\n (add-closing (try-handler ast handled))\n (restore ssa :shadow))\n {:as ssa finally :result} (if-some [ast (:finally ast)]\n (add-closing ssa ast)\n (dissoc ssa :result))]\n (assoc ssa :result (with-meta `(safe [~handled ~body] ~handler ~@(when finally (list finally))) met))))))\n (add-block [ssa]\n (let [block (sym (:prefix ssa) 'block (-> ssa :blocks count))]\n (-> ssa\n (update :blocks assoc block {})\n (update :caught conj-set block))))\n (add-place\n ([ssa init] (add-place ssa init nil))\n ([{:as ssa :keys [prefix places]} init tag]\n (let [block (current-block ssa)\n place (sym prefix 'place (count places))]\n (-> ssa\n (assoc :result place :tag tag)\n (assoc-in [:places place] {:init init :tag tag :block block})\n (update-in [:blocks block :bind] conj-vec place)))))\n (with-transition [ssa origin target write state & path]\n (-> ssa\n (assoc-in (into [:blocks origin] path) {:block target :write write :state state})\n (update-in [:blocks target :origins] conj-set origin)))\n (with-resume [ssa origin state]\n (with-transition ssa origin (current-block ssa) {} state :default))\n (with-clause-jump [ssa origin value]\n (with-transition ssa origin (current-block ssa) {}\n (sym (:prefix ssa) 'state) :clauses value))\n (with-default-jump [ssa origin]\n (with-transition ssa origin (current-block ssa) {}\n (sym (:prefix ssa) 'state) :default))\n (with-continue [ssa origin write]\n (with-transition ssa origin (current-block ssa) write\n (sym (:prefix ssa) 'state) :default))\n (with-joins [ssa target branches]\n (reduce-kv (fn [ssa block place]\n (with-continue ssa block {target place}))\n ssa branches))\n (with-handler [{:as ssa :keys [prefix]} caught write]\n (reduce (fn [ssa block]\n (with-transition ssa block (current-block ssa) write\n (sym prefix 'state) :handler))\n ssa caught))\n (add-many [ssa tag f & args]\n (-> (reduce with-place ssa (:result ssa))\n (add-place `(hint ~tag nil ~(apply f (map (partial emit-place ssa) (:tag ssa) (:result ssa)) args)) tag)))\n (add-break [ssa suspend resume]\n (-> (reduce with-place ssa (:result ssa))\n (add-block)\n (with-resume (current-block ssa) (cons suspend (:result ssa)))\n (add-place (list resume))))\n (add-recur [{:as ssa :keys [prefix] [block & targets] :loop places :result}]\n (-> (reduce with-place ssa (:result ssa))\n (with-transition (current-block ssa) block\n (zipmap targets places)\n (sym prefix 'state) :default)\n (dissoc :result)))\n (add-binding [{:as ssa, places :result} {:keys [name init]}]\n (let [{:as ssa, :keys [tag result]} (add-breaking ssa init)\n {:as ssa, place :result} (add-place ssa result tag)]\n (-> ssa\n (update :locals assoc name place)\n (assoc :result (conj places place)))))\n (add-bindings [ssa bindings f & args]\n (restore\n (apply f\n (reduce add-binding\n (assoc ssa :result [])\n bindings) args)\n ssa :locals))\n (add-loop-body [previous body]\n (as-> previous ssa\n (-> ssa\n (add-block)\n (with-default-jump (current-block ssa)))\n (-> ssa\n (assoc :loop (cons (current-block ssa) (:result ssa)))\n (add-breaking body))\n (restore ssa previous :loop)))\n (add-branch [ssa ast]\n (let [branches (:result ssa)\n ssa (add-breaking ssa ast)]\n (if (contains? ssa :result)\n (-> ssa\n (with-place (:result ssa))\n (assoc :result (assoc branches (current-block ssa) (:result ssa))))\n (assoc ssa :result branches))))\n (add-conditional [ssa test clauses default]\n (let [{:as ssa test :result} (add-breaking ssa test)\n block (current-block ssa)\n {:as ssa, target :result}\n (-> ssa\n (with-place test)\n (update-in [:blocks block] assoc :test test)\n (add-place nil))\n {:as ssa, branches :result}\n (-> (reduce-kv (fn [ssa test then]\n (-> ssa\n (add-block)\n (with-clause-jump block test)\n (add-branch then)))\n (assoc ssa :result {}) clauses)\n (add-block)\n (with-default-jump block)\n (add-branch default))]\n (if (zero? (count branches))\n (dissoc ssa :result)\n (-> ssa\n (add-block)\n (with-joins target branches)\n (with-place target)\n (assoc :result target)))))\n (add-breaking [ssa ast]\n (let [tag (-> ast :tag tag->symbol)\n met (ast-meta ast)]\n (case (:op ast)\n\n :with-meta\n (let [ssa (add-breaking ssa (:expr ast))]\n (update-in ssa [:places (:result ssa) :init] (partial list `with-meta) (:form (:meta ast))))\n\n :local\n (if-some [place (get-in ssa [:locals (:name ast)])]\n (-> ssa\n (with-place place)\n (add-place (emit-place ssa tag place) tag))\n (add-place ssa (:form ast) tag))\n\n :const\n (assoc ssa\n :result (:form ast)\n :tag tag)\n\n (:var :js-var :quote :the-var :static-field)\n (add-place ssa `(hint ~tag ~(-> ast :o-tag tag->symbol) ~(:form ast)) tag)\n\n (:fn :reify :deftype)\n (let [ssa (add-closing ssa ast)]\n (add-place ssa (:result ssa) tag))\n\n (:invoke :prim-invoke)\n (if-some [[suspend resume] (find (:breaks ssa) (-> ast function var-name))]\n (collect ssa add-breaking (:args ast) add-break suspend resume)\n (collect ssa add-breaking (cons (function ast) (:args ast)) add-many tag emit-apply met))\n\n :keyword-invoke\n (collect ssa add-breaking (list (:target ast)) add-many tag emit-apply met (-> ast :keyword :form))\n\n :protocol-invoke\n (collect ssa add-breaking (list* (:protocol-fn ast) (:target ast) (:args ast)) add-many tag emit-apply met)\n\n :instance?\n (collect ssa add-breaking (list (:target ast)) add-many tag emit-apply met `instance? (:class ast))\n\n (:instance-call :host-call)\n (collect ssa add-breaking (cons (instance ast) (:args ast)) add-many tag emit-member-access met (:method ast))\n\n (:instance-field :host-field :host-interop)\n (collect ssa add-breaking (cons (instance ast) (:args ast)) add-many tag emit-member-access met (field ast))\n\n :static-call\n (collect ssa add-breaking (:args ast) add-many tag emit-apply met '. (:class ast) (:method ast))\n\n :new\n (collect ssa add-breaking (:args ast) add-many tag emit-apply met 'new (constructor ast))\n\n :set!\n (let [{:keys [target val]} ast]\n (case (:op target)\n :var (collect ssa add-breaking [val] add-many tag emit-apply met `set! (:form target))\n (:instance-field :host-field :host-interop)\n (collect ssa add-breaking (list (instance target) val) add-many tag emit-member-assign met (field target))))\n\n :def\n (collect ssa add-breaking (list (:init ast)) add-many tag emit-apply met `def (with-meta (:name ast) (:val (:meta ast))))\n\n :js\n (collect ssa add-breaking (:args ast) add-many tag emit-apply met 'js* (js-template ast))\n\n :js-array\n (collect ssa add-breaking (:items ast) add-many tag emit-js-array met)\n\n :js-object\n (collect ssa add-breaking (:vals ast) add-many tag emit-js-object met (map coerce-js-literal-key (:keys ast)))\n\n :vector\n (collect ssa add-breaking (:items ast) add-many tag emit-vec met)\n\n :set\n (collect ssa add-breaking (:items ast) add-many tag emit-set met)\n\n :map\n (collect ssa add-breaking (interleave (:keys ast) (:vals ast)) add-many tag emit-map met)\n\n :let\n (add-bindings ssa (:bindings ast) add-breaking (:body ast))\n\n :loop\n (add-bindings ssa (:bindings ast) add-loop-body (:body ast))\n\n :recur\n (collect ssa add-breaking (:exprs ast) add-recur)\n\n :do\n (collect ssa add-breaking (:statements ast) add-breaking (:ret ast))\n\n :case\n (add-conditional ssa (:test ast) (zipmap (case-tests ast) (case-thens ast)) (:default ast))\n\n :if\n (add-conditional ssa (:test ast) {'(nil false) (:else ast)} (:then ast))\n\n :try\n (let [caught (:caught ssa)\n handled (or (:name ast) (sym (:prefix ssa) 'exception))\n {:as ssa target :result} (add-place ssa nil)\n {:as ssa status :result} (add-place ssa false)]\n (-> ssa\n (dissoc :result :caught)\n (add-block)\n (with-default-jump (current-block ssa))\n (add-branch (:body ast))\n (as-> ssa\n (-> ssa\n (dissoc :caught)\n (add-block)\n (with-handler (:caught ssa) {target (sym (:prefix ssa) 'exception)})\n (update :locals assoc handled target)\n (add-branch (try-handler ast handled))\n (restore ssa :locals))\n (-> ssa\n (assoc :caught caught)\n (add-block)\n (with-handler (:caught ssa) {status true target (sym (:prefix ssa) 'exception)})\n (with-joins target (:result ssa)))\n (if-some [ast (:finally ast)] (add-breaking ssa ast) ssa))\n (with-place target)\n (with-place status)\n (add-place `(if ~status (throw ~target) ~target))))\n\n :throw\n (-> ssa\n (collect add-breaking [(:exception ast)] add-many tag emit-apply met `throw)\n (dissoc :result))\n\n :monitor-enter\n (collect ssa add-breaking [(:target ast)] add-many tag emit-apply met '.monitorEnter (with-meta `unsafe `{:tag Unsafe}))\n\n :monitor-exit\n (collect ssa add-breaking [(:target ast)] add-many tag emit-apply met '.monitorExit (with-meta `unsafe `{:tag Unsafe}))\n\n :letfn\n (let [prev ssa\n block (current-block ssa)\n symbols (map :name (:bindings ast))\n {:as ssa :keys [locals]}\n (reduce (fn [{:as ssa :keys [prefix places]} local]\n (let [place (sym prefix 'place (count places))]\n (-> ssa\n (assoc-in [:locals local] place)\n (assoc-in [:places place :block] block))))\n ssa symbols)]\n (-> (reduce (fn [ssa {:keys [name init]}]\n (let [place (locals name)\n ssa (-> ssa\n (assoc-in [:locals (-> init :local :name)] place)\n (add-closing (dissoc init :local)))]\n (assoc-in ssa [:places place :init] (with-meta (:result ssa) nil))))\n ssa (:bindings ast))\n (update-in [:blocks block :bind] conj-vec (map locals symbols))\n (add-breaking (:body ast))\n (restore prev :locals))))))]\n (fn [ssa ast]\n (as-> (-> ssa (add-block) (add-breaking ast)) ssa\n (if-some [place (:result ssa)]\n (-> ssa\n (with-place place)\n (assoc-in [:blocks (current-block ssa) :default] {:state place})\n (dissoc :result)) ssa)\n (reduce (fn [ssa block]\n (assoc-in ssa [:blocks block :handler]\n {:state `(throw ~(sym (:prefix ssa) 'exception))}))\n (dissoc ssa :caught) (:caught ssa))))))\n\n(def span\n (letfn [(with-overlap [ssa p1 p2]\n (-> ssa\n (update-in [:places p1 :overlaps] conj-set p2)\n (update-in [:places p2 :overlaps] conj-set p1)))\n (backtrack [{:as ssa :keys [places blocks]} block place]\n (let [{:keys [heap origins]} (blocks block)]\n (as-> ssa ssa\n (update-in ssa [:blocks block :heap] conj-set place)\n (reduce (fn [ssa overlap] (with-overlap ssa overlap place)) ssa heap)\n (->> origins\n (remove (some-fn #{(-> places place :block)} (comp place :heap blocks)))\n (reduce (fn [ssa block] (backtrack ssa block place)) ssa)))))\n (span-block [ssa block {:keys [read]}]\n (reduce (fn [ssa place] (backtrack ssa block place)) ssa read))]\n (fn [{:as ssa :keys [blocks]}]\n (reduce-kv span-block ssa blocks))))\n\n(def color\n (letfn [(color-place [{:as ssa :keys [places]} place]\n (let [color (or (-> places place :color)\n (->> (range)\n (next)\n (remove (into #{}\n (comp (map (comp :color places)) (remove nil?))\n (-> places place :overlaps)))\n (first)))]\n (-> ssa\n (assoc-in [:places place :color] color)\n (update :colors max color))))]\n (fn [{:as ssa :keys [prefix blocks]}]\n (->> (range (count blocks))\n (mapcat (comp :heap blocks (partial sym prefix 'block)))\n (reduce color-place (assoc ssa :colors 0))))))\n\n(def emit\n (letfn [(emit-state-symbol [ssa]\n (with-meta (sym (:prefix ssa) 'state) {:tag 'objects}))\n\n (emit-fetch [ssa place]\n (let [{:keys [color tag]} (-> ssa :places place)]\n `(hint ~tag nil (aget ~(emit-state-symbol ssa) ~color))))\n\n (emit-store [ssa [place value]]\n `(aset ~(emit-state-symbol ssa)\n ~(get-in ssa [:places place :color])\n ~(when value `(hint nil ~(if-some [p (get-in ssa [:places value])]\n (:tag p) (tag->symbol (type value))) ~value))))\n\n (emit-jump [ssa origin {:keys [block write state]}]\n (let [{:keys [heap bind]} (get-in ssa [:blocks origin])\n needed (get-in ssa [:blocks block :heap] #{})]\n `(do\n (aset ~(emit-state-symbol ssa) 0 ~block)\n ~@(map (partial emit-store ssa)\n (concat (->> (zipmap heap (repeat nil))\n (remove (comp needed key)))\n (->> (merge write (zipmap bind bind))\n (filter (comp needed key)))))\n ~state)))\n\n (emit-block [{:as ssa :keys [places blocks prefix]} block]\n (let [{:keys [read bind test clauses default handler]} (get blocks block)\n tests (keys clauses) thens (vals clauses)]\n `(safe [~(sym prefix 'exception)\n (let [~@(mapcat (juxt identity (partial emit-fetch ssa)) read)]\n ~((fn rec [bind]\n (let [[items bind] (split-with symbol? bind)]\n (if-some [items (seq items)]\n `(let [~@(interleave items (map (comp :init places) items))]\n ~(rec bind))\n (if-some [[items & bind] (seq bind)]\n `(letfn* [~@(interleave items (map (comp :init places) items))]\n ~(rec bind))\n (case tests\n nil (emit-jump ssa block default)\n [[nil false]]\n `(if ~test\n ~(emit-jump ssa block default)\n ~(emit-jump ssa block (first thens)))\n `(case ~test\n ~@(interleave tests (map (partial emit-jump ssa block) thens))\n ~(emit-jump ssa block default))))))) bind))]\n ~(emit-jump ssa block handler))))]\n (fn [{:as ssa :keys [colors blocks prefix]}]\n `(letfn [~@(map (fn [block] (list block [(sym prefix 'state)] (emit-block ssa block))) (keys blocks))]\n (coroutine (doto (object-array ~(inc colors)) (aset 0 ~(sym prefix 'block 0))))))))\n\n(defn compile [prefix breaks env form]\n (-> {:prefix prefix\n :breaks (zipmap (map (comp var-name (partial analyze env)) (keys breaks)) (vals breaks))}\n (ssa (analyze env form))\n (span)\n (color)\n (emit)))\n" }, { "path": "test/cloroutine/core_test.cljc", "content": "(ns cloroutine.core-test\n (:require [cloroutine.core :refer [#?(:clj cr)]]\n [cloroutine.impl :refer [safe]]\n [clojure.test :refer [deftest is]])\n #?(:cljs (:require-macros [cloroutine.core :refer [cr]])))\n\n#?(:clj (set! *warn-on-reflection* true))\n\n(def check identity)\n(defn nop [])\n(def npe nil)\n\n(defn run [c & xs]\n (doseq [x xs]\n (is (= x (c)))))\n\n(def values [nil true false 0 \"clj\" :clj 'clj {:clj 42} #{\"clj\"} '[clj] '(clj)])\n(defprotocol P (p [_]))\n\n(deftest suite\n (doseq [value values] (run (cr {} value) value))\n (run (cr {} (* 6 7)) 42)\n (run (cr {check nop}\n (* (do (check 6) 6)\n (do (check 7) 7)))\n 6 7 42)\n (run (cr {} (if nil :then :else)) :else)\n (run (cr {} (if false :then :else)) :else)\n (run (cr {} (if true :then :else)) :then)\n (run (cr {} (if :ok :then :else)) :then)\n (run (cr {} (case nil :default)) :default)\n (run (cr {} (case nil nil :clause :default)) :clause)\n (run (cr {} (case :key :key :clause :default)) :clause)\n (run (cr {} (case 1 1 :clause :default)) :clause)\n (run (cr {} (safe [_ (try\n (check (throw #?(:clj (Error. \"This is fine.\") :cljs \"This is fine.\")))\n (catch #?(:clj Exception :cljs js/Error) _ :caught))]\n :thrown)) :thrown)\n (run (cr {check nop} (safe [_ (try (check (throw (ex-info \"This is fine.\" {})))\n (finally (check :finally)))] :thrown))\n :finally :thrown)\n (run (cr {check nop} (try 42 (finally (check :finally)))) :finally 42)\n (run (cr {check nop} (try (check (throw (ex-info \"This is fine.\" {})))\n (catch #?(:clj Exception :cljs js/Error) _ :exception)\n (catch #?(:clj Throwable :cljs :default) _ :throwable)))\n :exception)\n (run (cr {check nop} (safe [_ (do\n (try (npe) (finally (safe [_ (npe)] (check :caught))))\n (check :dead-code))] :caught)) :caught :caught)\n (run (cr {} (let [a 6\n b #(* a %)]\n (b 7))) 42)\n (run (cr {} (let [a 6\n b (fn [& xs] (apply * a xs))]\n (b 7))) 42)\n (run (cr {} (letfn [(a [] (b))\n (b [] 1)]\n (a))) 1)\n (run (cr {} ((cr {}))) nil)\n (run (cr {} (is (= 0 0))) true)\n (run (cr {} (let [a 42] (p (reify P (p [_] a))))) 42)\n (run (cr {} (.substring \"plop\" 2)) \"op\")\n (run (cr {} '(1 2 3)) '(1 2 3))\n (run (cr {} (loop [a :a b :b n 1]\n (if (pos? n)\n (recur b a (dec n))\n [a b]))) [:b :a])\n (run (cr {} (loop [x 0\n y (inc x)] y)) 1)\n (apply run (cr {check nop}\n (loop [x 0]\n (check x)\n (if (< x 100)\n (recur (inc x)))))\n (range 100))\n (apply run (cr {check nop} (dotimes [i 10] (check i)) 10) (range 11))\n (run (cr {check nop}\n (let [[x y] [1 2]] (+ x y))) 3)\n (run (cr {check nop}\n (let [{:keys [x y] x2 :x y2 :y :as foo} {:x 1 :y 2}]\n (check x)\n (check (and foo y x2 y2 foo))\n (+ x y))) 1 {:x 1 :y 2} 3)\n (run (cr {check nop}\n {:a (do (check 1) 1)\n :b (do (check 2) 2)})\n 1 2 {:a 1 :b 2})\n (run (cr {check nop}\n #{(do (check 1) 1)\n (do (check 2) 2)})\n 1 2 #{1 2})\n (run (cr {check nop}\n [(do (check 1) 1) (do (check 2) 2)])\n 1 2 [1 2])\n (run (cr {} (:foo {:foo :bar})) :bar)\n (run (cr {} ([1 2] 1)) 2)\n (run (cr {check nop}\n (loop []\n (when-let [x 10]\n (check (vec (for [i (range x)] i)))\n (if-not x (recur))))) (range 10) nil)\n (let [let* :foo]\n (run (cr {} (let* [x 3] x)) 3))\n (run (cr {} (loop [x 0]\n (case (int x)\n 0 (recur (inc x))\n 1 42))) 42)\n (run (cr {} (set! #?(:clj (.-gridx (java.awt.GridBagConstraints.))\n :cljs (.-state (volatile! nil))) 42)) 42)\n (run (cr {} ((comp) 42)) 42)\n ((cr {} (defn foo [] 41)))\n (is (= (foo) 41))\n #?(:cljs (run (cr {} (js->clj #js{:bar 1})) {\"bar\" 1}))\n #?(:cljs (run (cr {} (js->clj ((fn [] #js{:bar 1})))) {\"bar\" 1}))\n #?(:cljs (run (cr {} (js->clj #js[1 2 3])) [1 2 3]))\n #?(:cljs (run (cr {} (js->clj ((fn [] #js[1 2 3])))) [1 2 3]))\n #?(:cljs (run (cr {} (js* \"'~{}'\" \"Result\")) \"\\\"Result\\\"\"))\n #?(:cljs (run (cr {} (js->clj (js-obj \"key\" \"val\"))) {\"key\" \"val\"}))\n )\n" } ]