Repository: leonoel/cloroutine
Branch: master
Commit: 8e6e365d6dfa
Files: 14
Total size: 77.2 KB
Directory structure:
gitextract_lllilcc9/
├── .travis.yml
├── LICENSE
├── README.md
├── deps.edn
├── doc/
│ ├── 01-generators.md
│ ├── 02-async-await.md
│ ├── 03-conduits.md
│ ├── 04-delimited-continuations.md
│ └── 05-monads.md
├── src/
│ └── cloroutine/
│ ├── core.cljc
│ ├── impl/
│ │ ├── analyze_clj.clj
│ │ └── analyze_cljs.cljc
│ └── impl.cljc
└── test/
└── cloroutine/
└── core_test.cljc
================================================
FILE CONTENTS
================================================
================================================
FILE: .travis.yml
================================================
dist: xenial
sudo: true
language: clojure
script:
- clojure -Aclj-test
- clojure -Acljs-test
- clojure -Acljs-test -x planck
install:
- curl -O https://download.clojure.org/install/linux-install-1.10.1.447.sh
- chmod +x linux-install-1.10.1.447.sh
- sudo ./linux-install-1.10.1.447.sh
- sudo add-apt-repository -y ppa:mfikes/planck
- sudo apt-get update -y
- sudo apt-get install -y planck
================================================
FILE: LICENSE
================================================
Eclipse Public License - v 2.0
THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION
OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
1. DEFINITIONS
"Contribution" means:
a) in the case of the initial Contributor, the initial content
Distributed under this Agreement, and
b) in the case of each subsequent Contributor:
i) changes to the Program, and
ii) additions to the Program;
where such changes and/or additions to the Program originate from
and are Distributed by that particular Contributor. A Contribution
"originates" from a Contributor if it was added to the Program by
such Contributor itself or anyone acting on such Contributor's behalf.
Contributions do not include changes or additions to the Program that
are not Modified Works.
"Contributor" means any person or entity that Distributes the Program.
"Licensed Patents" mean patent claims licensable by a Contributor which
are necessarily infringed by the use or sale of its Contribution alone
or when combined with the Program.
"Program" means the Contributions Distributed in accordance with this
Agreement.
"Recipient" means anyone who receives the Program under this Agreement
or any Secondary License (as applicable), including Contributors.
"Derivative Works" shall mean any work, whether in Source Code or other
form, that is based on (or derived from) the Program and for which the
editorial revisions, annotations, elaborations, or other modifications
represent, as a whole, an original work of authorship.
"Modified Works" shall mean any work in Source Code or other form that
results from an addition to, deletion from, or modification of the
contents of the Program, including, for purposes of clarity any new file
in Source Code form that contains any contents of the Program. Modified
Works shall not include works that contain only declarations,
interfaces, types, classes, structures, or files of the Program solely
in each case in order to link to, bind by name, or subclass the Program
or Modified Works thereof.
"Distribute" means the acts of a) distributing or b) making available
in any manner that enables the transfer of a copy.
"Source Code" means the form of a Program preferred for making
modifications, including but not limited to software source code,
documentation source, and configuration files.
"Secondary License" means either the GNU General Public License,
Version 2.0, or any later versions of that license, including any
exceptions or additional permissions as identified by the initial
Contributor.
2. GRANT OF RIGHTS
a) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free copyright
license to reproduce, prepare Derivative Works of, publicly display,
publicly perform, Distribute and sublicense the Contribution of such
Contributor, if any, and such Derivative Works.
b) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free patent
license under Licensed Patents to make, use, sell, offer to sell,
import and otherwise transfer the Contribution of such Contributor,
if any, in Source Code or other form. This patent license shall
apply to the combination of the Contribution and the Program if, at
the time the Contribution is added by the Contributor, such addition
of the Contribution causes such combination to be covered by the
Licensed Patents. The patent license shall not apply to any other
combinations which include the Contribution. No hardware per se is
licensed hereunder.
c) Recipient understands that although each Contributor grants the
licenses to its Contributions set forth herein, no assurances are
provided by any Contributor that the Program does not infringe the
patent or other intellectual property rights of any other entity.
Each Contributor disclaims any liability to Recipient for claims
brought by any other entity based on infringement of intellectual
property rights or otherwise. As a condition to exercising the
rights and licenses granted hereunder, each Recipient hereby
assumes sole responsibility to secure any other intellectual
property rights needed, if any. For example, if a third party
patent license is required to allow Recipient to Distribute the
Program, it is Recipient's responsibility to acquire that license
before distributing the Program.
d) Each Contributor represents that to its knowledge it has
sufficient copyright rights in its Contribution, if any, to grant
the copyright license set forth in this Agreement.
e) Notwithstanding the terms of any Secondary License, no
Contributor makes additional grants to any Recipient (other than
those set forth in this Agreement) as a result of such Recipient's
receipt of the Program under the terms of a Secondary License
(if permitted under the terms of Section 3).
3. REQUIREMENTS
3.1 If a Contributor Distributes the Program in any form, then:
a) the Program must also be made available as Source Code, in
accordance with section 3.2, and the Contributor must accompany
the Program with a statement that the Source Code for the Program
is available under this Agreement, and informs Recipients how to
obtain it in a reasonable manner on or through a medium customarily
used for software exchange; and
b) the Contributor may Distribute the Program under a license
different than this Agreement, provided that such license:
i) effectively disclaims on behalf of all other Contributors all
warranties and conditions, express and implied, including
warranties or conditions of title and non-infringement, and
implied warranties or conditions of merchantability and fitness
for a particular purpose;
ii) effectively excludes on behalf of all other Contributors all
liability for damages, including direct, indirect, special,
incidental and consequential damages, such as lost profits;
iii) does not attempt to limit or alter the recipients' rights
in the Source Code under section 3.2; and
iv) requires any subsequent distribution of the Program by any
party to be under a license that satisfies the requirements
of this section 3.
3.2 When the Program is Distributed as Source Code:
a) it must be made available under this Agreement, or if the
Program (i) is combined with other material in a separate file or
files made available under a Secondary License, and (ii) the initial
Contributor attached to the Source Code the notice described in
Exhibit A of this Agreement, then the Program may be made available
under the terms of such Secondary Licenses, and
b) a copy of this Agreement must be included with each copy of
the Program.
3.3 Contributors may not remove or alter any copyright, patent,
trademark, attribution notices, disclaimers of warranty, or limitations
of liability ("notices") contained within the Program from any copy of
the Program which they Distribute, provided that Contributors may add
their own appropriate notices.
4. COMMERCIAL DISTRIBUTION
Commercial distributors of software may accept certain responsibilities
with respect to end users, business partners and the like. While this
license is intended to facilitate the commercial use of the Program,
the Contributor who includes the Program in a commercial product
offering should do so in a manner which does not create potential
liability for other Contributors. Therefore, if a Contributor includes
the Program in a commercial product offering, such Contributor
("Commercial Contributor") hereby agrees to defend and indemnify every
other Contributor ("Indemnified Contributor") against any losses,
damages and costs (collectively "Losses") arising from claims, lawsuits
and other legal actions brought by a third party against the Indemnified
Contributor to the extent caused by the acts or omissions of such
Commercial Contributor in connection with its distribution of the Program
in a commercial product offering. The obligations in this section do not
apply to any claims or Losses relating to any actual or alleged
intellectual property infringement. In order to qualify, an Indemnified
Contributor must: a) promptly notify the Commercial Contributor in
writing of such claim, and b) allow the Commercial Contributor to control,
and cooperate with the Commercial Contributor in, the defense and any
related settlement negotiations. The Indemnified Contributor may
participate in any such claim at its own expense.
For example, a Contributor might include the Program in a commercial
product offering, Product X. That Contributor is then a Commercial
Contributor. If that Commercial Contributor then makes performance
claims, or offers warranties related to Product X, those performance
claims and warranties are such Commercial Contributor's responsibility
alone. Under this section, the Commercial Contributor would have to
defend claims against the other Contributors related to those performance
claims and warranties, and if a court requires any other Contributor to
pay any damages as a result, the Commercial Contributor must pay
those damages.
5. NO WARRANTY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS"
BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR
IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF
TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR
PURPOSE. Each Recipient is solely responsible for determining the
appropriateness of using and distributing the Program and assumes all
risks associated with its exercise of rights under this Agreement,
including but not limited to the risks and costs of program errors,
compliance with applicable laws, damage to or loss of data, programs
or equipment, and unavailability or interruption of operations.
6. DISCLAIMER OF LIABILITY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS
SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST
PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE
EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
7. GENERAL
If any provision of this Agreement is invalid or unenforceable under
applicable law, it shall not affect the validity or enforceability of
the remainder of the terms of this Agreement, and without further
action by the parties hereto, such provision shall be reformed to the
minimum extent necessary to make such provision valid and enforceable.
If Recipient institutes patent litigation against any entity
(including a cross-claim or counterclaim in a lawsuit) alleging that the
Program itself (excluding combinations of the Program with other software
or hardware) infringes such Recipient's patent(s), then such Recipient's
rights granted under Section 2(b) shall terminate as of the date such
litigation is filed.
All Recipient's rights under this Agreement shall terminate if it
fails to comply with any of the material terms or conditions of this
Agreement and does not cure such failure in a reasonable period of
time after becoming aware of such noncompliance. If all Recipient's
rights under this Agreement terminate, Recipient agrees to cease use
and distribution of the Program as soon as reasonably practicable.
However, Recipient's obligations under this Agreement and any licenses
granted by Recipient relating to the Program shall continue and survive.
Everyone is permitted to copy and distribute copies of this Agreement,
but in order to avoid inconsistency the Agreement is copyrighted and
may only be modified in the following manner. The Agreement Steward
reserves the right to publish new versions (including revisions) of
this Agreement from time to time. No one other than the Agreement
Steward has the right to modify this Agreement. The Eclipse Foundation
is the initial Agreement Steward. The Eclipse Foundation may assign the
responsibility to serve as the Agreement Steward to a suitable separate
entity. Each new version of the Agreement will be given a distinguishing
version number. The Program (including Contributions) may always be
Distributed subject to the version of the Agreement under which it was
received. In addition, after a new version of the Agreement is published,
Contributor may elect to Distribute the Program (including its
Contributions) under the new version.
Except as expressly stated in Sections 2(a) and 2(b) above, Recipient
receives no rights or licenses to the intellectual property of any
Contributor under this Agreement, whether expressly, by implication,
estoppel or otherwise. All rights in the Program not expressly granted
under this Agreement are reserved. Nothing in this Agreement is intended
to be enforceable by any entity that is not a Contributor or Recipient.
No third-party beneficiary rights are created under this Agreement.
Exhibit A - Form of Secondary Licenses Notice
"This Source Code may also be made available under the following
Secondary Licenses when the conditions for such availability set forth
in the Eclipse Public License, v. 2.0 are satisfied: {name license(s),
version(s), and exceptions or additional permissions here}."
Simply including a copy of this Agreement, including this Exhibit A
is not sufficient to license the Source Code under Secondary Licenses.
If it is not possible or desirable to put the notice in a particular
file, then You may include the notice in a location (such as a LICENSE
file in a relevant directory) where a recipient would be likely to
look for such a notice.
You may add additional accurate notices of copyright ownership.
================================================
FILE: README.md
================================================
# cloroutine
A generic, macro-based, stackless coroutine builder for Clojure and ClojureScript.
[](https://clojars.org/cloroutine)
[](https://cljdoc.org/d/cloroutine/cloroutine/CURRENT)
[](https://travis-ci.org/leonoel/cloroutine)
[](LICENSE)
## Rationale
Coroutines 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.
This 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.
The 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.
## Reference
This library exposes a single namespace holding a single macro : [`cloroutine.core/cr`](src/cloroutine/core.cljc)
## Guides
The following guides show how to leverage the `cr` macro to implement clojure-flavored versions of various syntactic constructs involving suspendable processes.
1. [Generators as lazy sequences](doc/01-generators.md)
2. [Future-based asynchronous processes, aka async/await](doc/02-async-await.md)
3. [Transducers revisited](doc/03-conduits.md)
4. [Delimited continuations](doc/04-delimited-continuations.md)
5. [Monads](doc/05-monads.md)
================================================
FILE: deps.edn
================================================
{:deps
{org.clojure/tools.analyzer.jvm {:mvn/version "1.2.3"}}
:aliases
{:dev {:extra-paths ["test"]
:extra-deps {org.clojure/clojurescript {:mvn/version "1.11.60"}}}
:clj-test
{:extra-deps {io.github.cognitect-labs/test-runner
{:git/tag "v0.5.0" :git/sha "b3fd0d2"}}
:extra-paths ["test"]
:main-opts ["-m" "cognitect.test-runner"]}
:cljs-test
{:extra-deps {olical/cljs-test-runner {:mvn/version "3.8.0"}
org.clojure/clojurescript {:mvn/version "1.11.60"}}
:extra-paths ["test" "cljs-test-runner-out/gen"]
:main-opts ["-m" "cljs-test-runner.main"]}}}
================================================
FILE: doc/01-generators.md
================================================
# Generators as lazy sequences
In 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.
```clojure
(require '[cloroutine.core :refer [cr]])
```
First, 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.
```clojure
(def ^:dynamic *tail*)
(defn gen-seq [gen]
(lazy-seq (binding [*tail* (gen-seq gen)] (gen))))
```
We 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`.
```clojure
(defn yield [x]
(cons x *tail*))
(defn no-op [])
```
We 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.
```clojure
(defmacro generator [& body]
`(gen-seq (cr {yield no-op} ~@body nil)))
```
The generator machinery is done now, let's define some sequences :
```clojure
(generator
(yield :a)
(yield :b)
(yield :c)) ;; returns (:a :b :c)
```
```clojure
(defn my-repeat [x]
(generator
(loop []
(yield x)
(recur))))
(take 3 (my-repeat 'ho)) ;; returns (ho ho ho)
```
```clojure
(defn my-iterate [f x]
(generator
(loop [x x]
(yield x)
(recur (f x)))))
(take 10 (my-iterate (partial * 2) 1)) ;; returns (1 2 4 8 16 32 64 128 256 512)
```
```clojure
(def fibonacci
(generator
(loop [prev 0 curr 1]
(yield curr)
(recur curr (+ prev curr)))))
(take 10 fibonacci) ;; returns (1 1 2 3 5 8 13 21 34 55)
```
================================================
FILE: doc/02-async-await.md
================================================
# Future-based asynchronous processes, aka async/await
In 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.
This 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.
As 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.
```clojure
(require '[cloroutine.core :refer [cr]])
(import '(java.util.concurrent CompletableFuture))
```
First, 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`.
```clojure
(def ^:dynamic *fiber*)
(def ^:dynamic *value*)
(def ^:dynamic *error*)
(defn await [cf] (.whenComplete ^CompletableFuture cf *fiber*))
(defn thunk [] (if-some [e *error*] (throw e) *value*))
```
We 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.
```clojure
(defmacro async [& body]
`(let [cf# (CompletableFuture.)
cr# (cr {await thunk}
(try (.complete cf# (do ~@body))
(catch Throwable e#
(.completeExceptionally cf# e#))))]
(binding [*fiber* (reify java.util.function.BiConsumer
(accept [f# v# e#]
(binding [*fiber* f#
*value* v#
*error* e#]
(cr#))))]
(cr#)) cf#))
```
We can now define `async` blocks and use `await` inside to *park* on a future result.
```clojure
(def six (async 6)) ;; a future of 6
(def seven (async (inc (await six)))) ;; a future of 7
(def failed (async (throw (ex-info "this is fine." {})))) ;; a failed future
(def recovered (async (try (await failed) (catch Exception e :failed)))) ;; a future of :failed
```
================================================
FILE: doc/03-conduits.md
================================================
# Transducers revisited
In 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.
The 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.
```clojure
(require '[cloroutine.core :refer [cr]])
```
First, let's define some dynamic vars to hold thread-local context available during evaluation of conduit blocks.
* `*acc*` is the accumulator of the reducing process.
* `*down*` is the downstream reducing function
* `*input*` is the upstream value currently processed.
```clojure
(def ^:dynamic *acc*)
(def ^:dynamic *down*)
(def ^:dynamic *input*)
```
We can now define the functions in charge of I/O in `conduit`s.
* `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.
* `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.
* `input` is the resume function associated with `await`, its sole job is to retrieve input value from context.
```clojure
(defn yield [x]
(not (reduced? (set! *acc* (*down* *acc* x)))))
(defn await
([] (await ::done))
([eos] eos))
(defn input []
*input*)
```
Now, 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.
```clojure
(defn conduit-xf [ctor]
(fn [down]
(let [cor (ctor)
eos (volatile! (cor))]
(fn rf
([]
(down))
([acc]
(down (case @eos
::done acc
(rf acc @eos))))
([acc x]
(binding [*acc* acc
*down* down
*input* x]
(vreset! eos (cor))
*acc*))))))
```
The `conduit` macro now simply consists of wrapping a body in a coroutine, ensuring early termination of the reduction process when done.
```clojure
(defmacro conduit [& body]
`(conduit-xf
#(cr {await input}
~@body (set! *acc* (ensure-reduced *acc*)) ::done)))
```
Additionally, 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.
```clojure
(defmacro if-let-await [sym then else]
`(let [x# (await ::over)]
(case x#
::over ~else
(let [~sym x#] ~then))))
```
As 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).
```clojure
(defn mapping [f]
(conduit
(while true
(yield (f (await))))))
(defn mapping-indexed [f]
(conduit
(loop [i 0]
(yield (f i (await)))
(recur (inc i)))))
(defn filtering [pred]
(conduit
(while true
(let [val (await)]
(when (pred val)
(yield val))))))
(defn taking-while [pred]
(conduit
(loop []
(let [val (await)]
(when (pred val)
(yield val)
(recur))))))
(defn taking [n]
(conduit
(dotimes [_ n]
(yield (await)))))
(defn taking-nth [n]
(conduit
(while true
(yield (await))
(dotimes [_ (- n 1)]
(await)))))
(defn dropping [n]
(conduit
(dotimes [_ n]
(await))
(while true
(yield (await)))))
(defn dropping-while [pred]
(conduit
(loop [v (await)]
(if (pred v)
(recur (await))
(yield v)))
(while true
(yield (await)))))
(def catting
(conduit
(while true
(doseq [val (await)]
(yield val)))))
(defn mapcatting [f]
(conduit
(while true
(doseq [val (f (await))]
(yield val)))))
(def deduping
(conduit
(loop [old ::none]
(let [new (await)]
(when-not (= old new)
(yield new))
(recur new)))))
(defn replacing [smap]
(conduit
(while true
(let [val (await)]
(yield (get smap val val))))))
(defn keeping [f]
(conduit
(while true
(let [v (f (await))]
(when-not (nil? v)
(yield v))))))
(defn keeping-indexed [f]
(conduit
(loop [i 0]
(let [v (f i (await))]
(when-not (nil? v)
(yield v)))
(recur (inc i)))))
(def distincting
(conduit
(loop [seen #{}]
(let [val (await)]
(if-not (contains? seen val)
(do (yield val)
(recur (conj seen val)))
(recur seen))))))
(defn random-sampling [prob]
(conduit
(while true
(let [val (await)]
(when (< (rand) prob)
(yield val))))))
(defn interposing [sep]
(conduit
(yield (await))
(while true
(let [val (await)]
(yield sep)
(yield val)))))
(defn partitioning-all [n]
(conduit
(loop [vs [(await)]]
(if (= n (count vs))
(do (yield vs)
(recur [(await)]))
(if-let-await v
(recur (conj vs v))
(yield vs))))))
(defn partitioning-by [f]
(conduit
(let [first-val (await)]
(loop [vs [first-val]
to-cmp (f first-val)]
(if-let-await v
(let [new-to-cmp (f v)]
(if (= to-cmp new-to-cmp)
(recur (conj vs v) to-cmp)
(do (yield vs)
(recur [v] new-to-cmp))))
(yield vs))))))
```
================================================
FILE: doc/04-delimited-continuations.md
================================================
# Delimited continuations
In 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.
If you're familiar with scheme's operators, ours will be slightly different :
* 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.
* 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.
What we want is to write code like this :
```clojure
(* 2 (reset (+ 1 (shift function with some args))))
```
And be it equivalent to this :
```clojure
(* 2 (function #(+ 1 %) with some args))
```
`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.
```clojure
(require '[cloroutine.core :refer [cr]])
```
Our dynamic context will hold the coroutine currently running in `*coroutine*`, and the argument passed to the continuation in `*result*`.
```clojure
(def ^:dynamic *coroutine*)
(def ^:dynamic *result*)
```
`run` will be used to start/resume the coroutine, binding it to the dynamic context.
```clojure
(defn run [c]
(binding [*coroutine* c] (c)))
```
`fork` will be called on continuation. It binds its argument to the dynamic context, then clones the parent coroutine and resumes it.
```clojure
(defn fork [c x]
(binding [*result* x] (c run)))
```
`shift` captures the coroutine currently running, builds a continuation from it, passes it to given function and returns the result.
```clojure
(defn shift [f & args]
(apply f (partial fork *coroutine*) args))
```
`thunk` will provide the continuation argument on coroutine resume, defining the result of `shift` in the `reset` body.
```clojure
(defn thunk [] *result*)
```
`reset` builds the coroutine and immediately runs it.
```clojure
(defmacro reset [& body]
`(run (cr {shift thunk} ~@body)))
```
And we're done.
```clojure
(reset (* 2 (shift map (range 3))))
#_=> (0 2 4)
```
================================================
FILE: doc/05-monads.md
================================================
# Monads
A monad refers to a category of values associated with a pair of functions `[unit bind]` such that :
* `(unit x)` returns a member of this category given any value `x`
* `(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.
* `(bind f (unit x))` is equivalent to `(f x)`
* `(bind unit m)` is equivalent to `m`
* `(->> m (bind f) (bind g))` is equivalent to `(bind #(bind g (f %)) m)`
Some monads :
```clojure
;; clojure sequences are monadic out of the box.
(def seqable-monad [list mapcat])
;; a monad short-circuiting computation on nil.
(def nilable-monad [identity (fn [f x] (when (some? x) (f x)))])
```
The 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).
```clojure
(defmacro mlet [monad bindings & body]
(if-some [[s m & bindings] (seq bindings)]
`((second ~monad) (fn [~s] (mlet ~monad ~bindings ~@body)) ~m)
`((first ~monad) (do ~@body))))
(mlet seqable-monad
[x [1 2]
y [3 4]]
(* x y))
#_=> (3 4 6 8)
(mlet nilable-monad
[x 1
y nil
z 2]
(* x y z))
#_=> nil
```
This 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.
```clojure
(mdo seqable-monad
(* (>>= [1 2]) (>>= [3 4])))
#_=> (3 4 6 8)
(mdo nilable-monad
(* (>>= 1) (>>= nil) (>>= 2)))
#_=> nil
```
This 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.
```clojure
(require '[cloroutine.core :refer [cr]])
```
Our 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*`.
```clojure
(def ^:dynamic *coroutine*)
(def ^:dynamic *bind*)
(def ^:dynamic *result*)
```
`run` will be used to start/resume the coroutine, binding it to the dynamic context along with the monad's bind function.
```clojure
(defn run [c b]
(binding [*coroutine* c
*bind* b] (c)))
```
`fork` will be called on continuation. It binds its argument to the dynamic context, then clone the parent coroutine and resumes it.
```clojure
(defn fork [c b r]
(binding [*result* r]
(c run b)))
```
`>>=` 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.
```clojure
(defn >>= [m]
(*bind* (partial fork *coroutine* *bind*) m))
```
`=<<` will be the coroutine resume function, returning the argument passed to the continuation from dynamic context.
```clojure
(defn =<< [] *result*)
```
`mdo` builds the coroutine and immediately runs it.
```clojure
(defmacro mdo [monad & body]
`(run (cr {>>= =<<} ((first ~monad) (do ~@body))) (second ~monad)))
```
As a final example, let's define the state monad and reimplement the parsing game from [haskell documentation](https://wiki.haskell.org/State_Monad).
```clojure
(def state-monad
[(fn [x] (fn [s] [x s]))
(fn [f m] (fn [s] (let [[x s] (m s)] ((f x) s))))])
(defn state-eval [m s]
(first (m s)))
(defn state-get [s]
[s s])
(defn state-set [s]
(fn [_] [nil s]))
(defn game [input]
(mdo state-monad
(let [[on score] (>>= state-get)]
(if-some [[x & xs] (seq input)]
(do (case x
\a (when on (>>= (state-set [on (inc score)])))
\b (when on (>>= (state-set [on (dec score)])))
\c (>>= (state-set [(not on) score])))
(>>= (game xs))) score))))
(defn play [input]
(state-eval (game input) [false 0]))
(play "abcaaacbbcabbab")
#_=> 2
```
================================================
FILE: src/cloroutine/core.cljc
================================================
(ns cloroutine.core (:require [cloroutine.impl :as i]))
(defmacro
^{:arglists '([breaks & body]) :doc "
Builds a coroutine evaluating body (in an implicit do), suspending evaluation at
call sites defined in the breaks map. The breaks map associates suspend vars to
resume vars, both given as fully-qualified symbols.
A coroutine is a stateful zero-arity function. Calling a coroutine in initial or
suspended state starts or resumes evaluation and returns the result of the next
encountered suspend var call or final body expression.
After calling a suspend var, the coroutine is in suspended state. A subsequent
coroutine call will resume body evaluation, the result of the suspend var call
being substituted with the result of calling its associated resume var with zero
argument.
After reaching final body expression, or getting an uncaught exception, the
coroutine is in terminated state. Subsequent calls have undefined behavior.
The state of a coroutine is not synchronized, each call to a suspend var is
expected to happen-before its associated coroutine resume call.
Suspend and resume vars are guaranteed to be called synchronously in the thread
calling the coroutine. For this reason, the cr macro will ignore breaking vars
in code able to escape synchronous execution context. This includes function
bodies and custom type methods.
Calling the non-zero arity of a coroutine will clone the coroutine and pass the
copy to the function provided as first argument, and return the result. Other
arguments are passed to the function as-is.
"} cr [breaks & body]
(i/compile (gensym "cr") breaks &env (cons `do body)))
================================================
FILE: src/cloroutine/impl/analyze_clj.clj
================================================
(ns cloroutine.impl.analyze-clj
(:require [clojure.tools.analyzer.jvm :as clj])
(:import (clojure.lang Compiler$LocalBinding)))
(defn analyze [env form]
(binding [clj/run-passes clj/scheduled-default-passes]
(->> env
(into {} (map (fn [[symbol binding]]
[symbol (or (when (instance? Compiler$LocalBinding binding)
(let [binding ^Compiler$LocalBinding binding]
{:op :local
:tag (when (.hasJavaClass binding)
(some-> binding (.getJavaClass)))
:form symbol
:name symbol}))
binding)])))
(update (clj/empty-env) :locals merge)
(clj/analyze form))))
================================================
FILE: src/cloroutine/impl/analyze_cljs.cljc
================================================
(ns cloroutine.impl.analyze-cljs
(:require [cljs.analyzer]
[cljs.env]))
(defn analyze [env form]
(binding [cljs.env/*compiler* (or cljs.env/*compiler*
(cljs.env/default-compiler-env))]
(cljs.analyzer/analyze env form nil nil)))
================================================
FILE: src/cloroutine/impl.cljc
================================================
(ns ^:no-doc cloroutine.impl
(:refer-clojure :exclude [compile])
(:require #?(:cljs [cloroutine.impl.analyze-cljs :as impl]
:clj [cloroutine.impl.analyze-clj :as impl]))
#?(:cljs (:require-macros [cloroutine.impl :refer [safe hint]])
:clj (:import (clojure.lang IObj)
(java.lang.reflect Field Modifier)
(sun.misc Unsafe))))
(def unsafe
#?(:clj
(some (fn [^Field f]
(when (Modifier/isStatic (.getModifiers f))
(when (= Unsafe (.getType f))
(.setAccessible f true)
(.get f nil))))
(.getDeclaredFields Unsafe))
:default nil))
(def box->prim
'{java.lang.Boolean boolean
java.lang.Byte byte
java.lang.Character char
java.lang.Short short
java.lang.Integer int
java.lang.Long long
java.lang.Float float
java.lang.Double double})
(def prim->box
(reduce-kv #(assoc %1 %3 %2) {} box->prim))
(defn class->symbol [c]
#?(:clj
(when (instance? Class c)
(let [s (symbol (.getName ^Class c))]
(get box->prim s s)))))
(defn tag->symbol [c]
(or
(when (symbol? c) c)
(class->symbol c)))
(defn with-tag [form tag]
(if #?(:clj (instance? IObj form) :cljs (satisfies? IMeta form))
(with-meta form (assoc (meta form) :tag tag)) form))
(defn var-name [ast]
(when (= :var (:op ast))
(or (when-some [v (:info ast)]
(:name v))
(when-some [v (:meta ast)]
(symbol (str (:ns v)) (name (:name v)))))))
(defmacro hint [to from form]
(if (:js-globals &env)
(with-tag form to)
(if (prim->box to)
(list to form)
(if-some [from-box (prim->box from)]
(with-tag (list (symbol (str from-box "/valueOf")) form) to)
(with-tag form to)))))
(defmacro safe [[error success] failure & finally]
`(try ~success
(catch ~(if (:js-globals &env) :default `Throwable) ~error ~failure)
~@(when finally (list `(finally ~@finally)))))
(defn coroutine [^objects state]
(fn
([]
(let [result ((aget state 0) state)]
(if (identical? result state)
(recur) result)))
([f] (f (coroutine (aclone state))))
([f a] (f (coroutine (aclone state)) a))
([f a b] (f (coroutine (aclone state)) a b))
([f a b c] (f (coroutine (aclone state)) a b c))
([f a b c & ds] (apply f (coroutine (aclone state)) a b c ds))))
(defn sym [& args]
(symbol (apply str (interpose "-" args))))
(def conj-vec (fnil conj []))
(def conj-set (fnil conj #{}))
(def into-set (fnil into #{}))
(defn- cljs-provided? []
#?(:cljs true
:clj (boolean (requiring-resolve 'cljs.env/default-compiler-env))))
(defn analyze [env form]
(if (and (:js-globals env) (cljs-provided?))
#?(:cljs (impl/analyze env form)
:clj ((requiring-resolve 'cloroutine.impl.analyze-cljs/analyze) env form))
#?(:cljs (throw (ex-info "Can't target JVM from clojurescript." {}))
:clj (impl/analyze env form))))
(defn coerce-js-literal-key [k]
(or
(and (string? k) k)
(and (keyword? k) (nil? (namespace k)) (name k))
(throw (ex-info (str "Invalid JS literal key - " k) {:key k}))))
(def ssa
(letfn [(emit-apply [args meta & prefixes]
(with-meta `(~@prefixes ~@args) meta))
(emit-member-access [[inst & args] meta member]
(with-meta `(. ~inst ~member ~@args) meta))
(emit-member-assign [[inst val] meta member]
(with-meta `(set! (. ~inst ~member) ~val) meta))
(emit-case [[test default & thens] meta tests]
(with-meta `(case ~test ~@(interleave tests thens) ~default) meta))
(emit-vec [args meta]
(with-meta (vec args) meta))
(emit-set [args meta]
(with-meta (set args) meta))
(emit-map [args meta]
(with-meta (apply hash-map args) meta))
(emit-js-object [args meta keys]
(with-meta (cons 'cljs.core/js-obj (interleave keys args)) meta))
(emit-js-array [args meta]
(with-meta (cons 'cljs.core/array args) meta))
(emit-place [{:keys [places]
:as ssa}
tag place]
`(hint ~tag
~(when (contains? places place)
(-> places place :tag))
~place))
(instance [ast]
(or (:instance ast) (:target ast)))
(field [ast]
(symbol (str "-" (or (:field ast) (:m-or-f ast)))))
(case-tests [{:keys [tests nodes]}]
(if tests
(map (comp list :form) tests)
(map (comp (partial map :form) :tests) nodes)))
(case-thens [{:keys [thens nodes]}]
(if thens
(map :then thens)
(map (comp :then :then) nodes)))
(try-handler [ast sym]
(if (:name ast)
(:catch ast)
((fn rec [catch catches]
(if-some [[{{class :val} :class :keys [local body]} & catches] catches]
(let [then {:op :let
:bindings [(assoc local :init {:op :local :name sym})]
:body body}]
(case class
java.lang.Throwable then
{:op :if
:test {:op :instance?
:class class
:target {:op :local :name sym}}
:then then
:else (rec catch catches)}))
catch))
{:op :throw
:exception {:op :local :name sym}}
(seq (:catches ast)))))
(constructor [{:keys [class]}]
(or (:val class) (:name class)))
(ast-meta [ast]
(select-keys (:env ast) [:file :column :line]))
(function [ast]
(or (:f ast) (:fn ast)))
(js-template [ast]
(or (:code ast) (apply str (interpose "~{}" (:segs ast)))))
(restore [m p & ks]
(reduce (fn [m k]
(if-some [x (p k)]
(assoc m k x)
(dissoc m k))) m ks))
(current-block [ssa]
(sym (:prefix ssa) 'block (-> ssa :blocks count dec)))
(with-place [{:keys [places]
:as ssa}
place]
(let [block (current-block ssa)]
(if (or (not (contains? places place))
(= block (-> places place :block)))
ssa (update-in ssa [:blocks block :read] conj-set place))))
(collect [ssa rf asts f & args]
(loop [ssa (assoc ssa :result [] :tag [])
asts (seq asts)]
(if-some [[ast & asts] asts]
(let [res (:result ssa)
tag (:tag ssa)
ssa (rf ssa ast)]
(if (contains? ssa :result)
(recur (-> ssa
(update :result (partial conj res))
(update :tag (partial conj tag))) asts) ssa))
(apply f ssa args))))
(add-closing-method [ssa {:keys [variadic? params body]}]
(-> ssa
(update :shadow into-set (map :name) params)
(add-closing body)
(restore ssa :shadow)
(update :result (partial list (if variadic?
(-> (into [] (map :name) (pop params))
(conj '& (-> params peek :name)))
(into [] (map :name) params))))))
(add-closing [ssa ast]
(let [met (ast-meta ast)]
(case (:op ast)
:with-meta
(let [ssa (add-closing ssa (:expr ast))]
(update ssa :result (partial list `with-meta) (:form (:meta ast))))
(:const :var :js-var :quote :the-var :static-field)
(assoc ssa :result (:form ast))
:local
(let [l (:name ast)
s (get-in ssa [:shadow l])
p (get-in ssa [:locals l])]
(if s
(assoc ssa :result `(hint ~(-> ast :tag tag->symbol) ~(:tag met) ~s))
(if p
(-> ssa
(with-place p)
(assoc :result (emit-place ssa (:tag met) p)))
(assoc ssa :result `(hint ~(-> ast :tag tag->symbol) ~(:tag met) ~l)))))
(:let :loop)
(let [previous ssa
{:keys [op bindings body]} ast
{:as ssa bindings :result}
(reduce (fn [{:as ssa bindings :result} {:keys [name init]}]
(let [{:as ssa init :result} (add-closing ssa init)]
(-> ssa
(assoc :result (conj bindings name init))
(update :shadow conj-set name))))
(assoc ssa :result []) bindings)
{:as ssa body :result}
(add-closing ssa body)]
(-> ssa
(restore previous :shadow)
(assoc :result (emit-apply [bindings body] met (case op :let `let* :loop `loop*)))))
(:invoke :prim-invoke)
(collect ssa add-closing (cons (function ast) (:args ast)) update :result emit-apply met)
:keyword-invoke
(collect ssa add-closing (list (:target ast)) update :result emit-apply met (-> ast :keyword :form))
:protocol-invoke
(collect ssa add-closing (list* (:protocol-fn ast) (:target ast) (:args ast)) update :result emit-apply met)
:instance?
(collect ssa add-closing (list (:target ast)) update :result emit-apply met `instance? (:class ast))
(:instance-call :host-call)
(collect ssa add-closing (cons (instance ast) (:args ast)) update :result emit-member-access met (:method ast))
(:instance-field :host-field :host-interop)
(collect ssa add-closing (cons (instance ast) (:args ast)) update :result emit-member-access met (field ast))
:static-call
(collect ssa add-closing (:args ast) update :result emit-apply met '. (:class ast) (:method ast))
:new
(collect ssa add-closing (:args ast) update :result emit-apply met 'new (constructor ast))
:set!
(collect ssa add-closing [(:target ast) (:val ast)] update :result emit-apply met `set!)
:def
(collect ssa add-closing (list (:init ast)) update :result emit-apply met `def (-> ast :var :form))
:js
(collect ssa add-closing (:args ast) update :result emit-apply met 'js* (js-template ast))
:js-array
(collect ssa add-closing (:items ast) update :result emit-js-array met)
:js-object
(collect ssa add-closing (:vals ast) update :result emit-js-object met (map coerce-js-literal-key (:keys ast)))
:vector
(collect ssa add-closing (:items ast) update :result emit-vec met)
:set
(collect ssa add-closing (:items ast) update :result emit-set met)
:map
(collect ssa add-closing (interleave (:keys ast) (:vals ast)) update :result emit-map met)
:recur
(collect ssa add-closing (:exprs ast) update :result emit-apply met `recur)
:do
(collect ssa add-closing (conj (vec (:statements ast)) (:ret ast)) update :result emit-apply met `do)
:if
(collect ssa add-closing [(:test ast) (:then ast) (:else ast)] update :result emit-apply met `if)
:case
(collect ssa add-closing (list* (:test ast) (:default ast) (case-thens ast))
update :result emit-case met (case-tests ast))
:throw
(collect ssa add-closing (list (:exception ast)) update :result emit-apply met `throw)
:monitor-enter
(collect ssa add-closing (list (:target ast)) update :result emit-apply met 'monitor-enter)
:monitor-exit
(collect ssa add-closing (list (:target ast)) update :result emit-apply met 'monitor-exit)
:fn
(let [local (:local ast)
cljs-crap (when-some [t (-> ast :methods first :type)] {:cljs.analyzer/type t})]
(-> (reduce (fn [ssa method]
(-> ssa
(add-closing-method method)
(update :result (partial conj-vec (:result ssa)))))
(-> (if local (update ssa :shadow conj-set (:name local)) ssa)
(dissoc :result)) (:methods ast))
(restore ssa :shadow)
(update :result (if local (partial cons (:name local)) identity))
(update :result emit-apply (merge met cljs-crap) 'fn*)))
:reify
(-> (reduce (fn [ssa method]
(-> ssa
(add-closing-method (update method :params (partial into [(:this method)])))
(update :result (partial cons (:name method)))
(update :result (partial conj (:result ssa)))))
(assoc ssa :result []) (:methods ast))
(update :result (->> (-> (:interfaces ast) #?(:clj (disj IObj)))
(map tag->symbol)
(apply partial list* `reify))))
:deftype
(let [{:keys [t fields pmasks protocols body]} ast]
(-> ssa
(update :shadow into-set fields)
(add-closing body)
(restore ssa :shadow)
(update :result (partial list `deftype* (vary-meta t assoc :protocols protocols) fields pmasks))))
:letfn
(let [prev ssa
{:keys [bindings body]} ast
{:as ssa bindings :result}
(reduce (fn [{:as ssa bindings :result} {:keys [init name]}]
(-> ssa
(add-closing (dissoc init :local))
(update :result with-meta nil)
(update :result (partial conj-vec bindings name))))
(-> ssa
(assoc :result [])
(update :shadow into-set (map :name) bindings)) bindings)]
(-> ssa
(add-closing body)
(restore prev :shadow)
(update :result list)
(update :result emit-apply met 'letfn* bindings)))
:try
(let [handled (or (:name ast) (sym (:prefix ssa) 'exception))
{:as ssa body :result} (add-closing ssa (:body ast))
{:as ssa handler :result} (-> ssa
(update :shadow conj-set handled)
(add-closing (try-handler ast handled))
(restore ssa :shadow))
{:as ssa finally :result} (if-some [ast (:finally ast)]
(add-closing ssa ast)
(dissoc ssa :result))]
(assoc ssa :result (with-meta `(safe [~handled ~body] ~handler ~@(when finally (list finally))) met))))))
(add-block [ssa]
(let [block (sym (:prefix ssa) 'block (-> ssa :blocks count))]
(-> ssa
(update :blocks assoc block {})
(update :caught conj-set block))))
(add-place
([ssa init] (add-place ssa init nil))
([{:as ssa :keys [prefix places]} init tag]
(let [block (current-block ssa)
place (sym prefix 'place (count places))]
(-> ssa
(assoc :result place :tag tag)
(assoc-in [:places place] {:init init :tag tag :block block})
(update-in [:blocks block :bind] conj-vec place)))))
(with-transition [ssa origin target write state & path]
(-> ssa
(assoc-in (into [:blocks origin] path) {:block target :write write :state state})
(update-in [:blocks target :origins] conj-set origin)))
(with-resume [ssa origin state]
(with-transition ssa origin (current-block ssa) {} state :default))
(with-clause-jump [ssa origin value]
(with-transition ssa origin (current-block ssa) {}
(sym (:prefix ssa) 'state) :clauses value))
(with-default-jump [ssa origin]
(with-transition ssa origin (current-block ssa) {}
(sym (:prefix ssa) 'state) :default))
(with-continue [ssa origin write]
(with-transition ssa origin (current-block ssa) write
(sym (:prefix ssa) 'state) :default))
(with-joins [ssa target branches]
(reduce-kv (fn [ssa block place]
(with-continue ssa block {target place}))
ssa branches))
(with-handler [{:as ssa :keys [prefix]} caught write]
(reduce (fn [ssa block]
(with-transition ssa block (current-block ssa) write
(sym prefix 'state) :handler))
ssa caught))
(add-many [ssa tag f & args]
(-> (reduce with-place ssa (:result ssa))
(add-place `(hint ~tag nil ~(apply f (map (partial emit-place ssa) (:tag ssa) (:result ssa)) args)) tag)))
(add-break [ssa suspend resume]
(-> (reduce with-place ssa (:result ssa))
(add-block)
(with-resume (current-block ssa) (cons suspend (:result ssa)))
(add-place (list resume))))
(add-recur [{:as ssa :keys [prefix] [block & targets] :loop places :result}]
(-> (reduce with-place ssa (:result ssa))
(with-transition (current-block ssa) block
(zipmap targets places)
(sym prefix 'state) :default)
(dissoc :result)))
(add-binding [{:as ssa, places :result} {:keys [name init]}]
(let [{:as ssa, :keys [tag result]} (add-breaking ssa init)
{:as ssa, place :result} (add-place ssa result tag)]
(-> ssa
(update :locals assoc name place)
(assoc :result (conj places place)))))
(add-bindings [ssa bindings f & args]
(restore
(apply f
(reduce add-binding
(assoc ssa :result [])
bindings) args)
ssa :locals))
(add-loop-body [previous body]
(as-> previous ssa
(-> ssa
(add-block)
(with-default-jump (current-block ssa)))
(-> ssa
(assoc :loop (cons (current-block ssa) (:result ssa)))
(add-breaking body))
(restore ssa previous :loop)))
(add-branch [ssa ast]
(let [branches (:result ssa)
ssa (add-breaking ssa ast)]
(if (contains? ssa :result)
(-> ssa
(with-place (:result ssa))
(assoc :result (assoc branches (current-block ssa) (:result ssa))))
(assoc ssa :result branches))))
(add-conditional [ssa test clauses default]
(let [{:as ssa test :result} (add-breaking ssa test)
block (current-block ssa)
{:as ssa, target :result}
(-> ssa
(with-place test)
(update-in [:blocks block] assoc :test test)
(add-place nil))
{:as ssa, branches :result}
(-> (reduce-kv (fn [ssa test then]
(-> ssa
(add-block)
(with-clause-jump block test)
(add-branch then)))
(assoc ssa :result {}) clauses)
(add-block)
(with-default-jump block)
(add-branch default))]
(if (zero? (count branches))
(dissoc ssa :result)
(-> ssa
(add-block)
(with-joins target branches)
(with-place target)
(assoc :result target)))))
(add-breaking [ssa ast]
(let [tag (-> ast :tag tag->symbol)
met (ast-meta ast)]
(case (:op ast)
:with-meta
(let [ssa (add-breaking ssa (:expr ast))]
(update-in ssa [:places (:result ssa) :init] (partial list `with-meta) (:form (:meta ast))))
:local
(if-some [place (get-in ssa [:locals (:name ast)])]
(-> ssa
(with-place place)
(add-place (emit-place ssa tag place) tag))
(add-place ssa (:form ast) tag))
:const
(assoc ssa
:result (:form ast)
:tag tag)
(:var :js-var :quote :the-var :static-field)
(add-place ssa `(hint ~tag ~(-> ast :o-tag tag->symbol) ~(:form ast)) tag)
(:fn :reify :deftype)
(let [ssa (add-closing ssa ast)]
(add-place ssa (:result ssa) tag))
(:invoke :prim-invoke)
(if-some [[suspend resume] (find (:breaks ssa) (-> ast function var-name))]
(collect ssa add-breaking (:args ast) add-break suspend resume)
(collect ssa add-breaking (cons (function ast) (:args ast)) add-many tag emit-apply met))
:keyword-invoke
(collect ssa add-breaking (list (:target ast)) add-many tag emit-apply met (-> ast :keyword :form))
:protocol-invoke
(collect ssa add-breaking (list* (:protocol-fn ast) (:target ast) (:args ast)) add-many tag emit-apply met)
:instance?
(collect ssa add-breaking (list (:target ast)) add-many tag emit-apply met `instance? (:class ast))
(:instance-call :host-call)
(collect ssa add-breaking (cons (instance ast) (:args ast)) add-many tag emit-member-access met (:method ast))
(:instance-field :host-field :host-interop)
(collect ssa add-breaking (cons (instance ast) (:args ast)) add-many tag emit-member-access met (field ast))
:static-call
(collect ssa add-breaking (:args ast) add-many tag emit-apply met '. (:class ast) (:method ast))
:new
(collect ssa add-breaking (:args ast) add-many tag emit-apply met 'new (constructor ast))
:set!
(let [{:keys [target val]} ast]
(case (:op target)
:var (collect ssa add-breaking [val] add-many tag emit-apply met `set! (:form target))
(:instance-field :host-field :host-interop)
(collect ssa add-breaking (list (instance target) val) add-many tag emit-member-assign met (field target))))
:def
(collect ssa add-breaking (list (:init ast)) add-many tag emit-apply met `def (with-meta (:name ast) (:val (:meta ast))))
:js
(collect ssa add-breaking (:args ast) add-many tag emit-apply met 'js* (js-template ast))
:js-array
(collect ssa add-breaking (:items ast) add-many tag emit-js-array met)
:js-object
(collect ssa add-breaking (:vals ast) add-many tag emit-js-object met (map coerce-js-literal-key (:keys ast)))
:vector
(collect ssa add-breaking (:items ast) add-many tag emit-vec met)
:set
(collect ssa add-breaking (:items ast) add-many tag emit-set met)
:map
(collect ssa add-breaking (interleave (:keys ast) (:vals ast)) add-many tag emit-map met)
:let
(add-bindings ssa (:bindings ast) add-breaking (:body ast))
:loop
(add-bindings ssa (:bindings ast) add-loop-body (:body ast))
:recur
(collect ssa add-breaking (:exprs ast) add-recur)
:do
(collect ssa add-breaking (:statements ast) add-breaking (:ret ast))
:case
(add-conditional ssa (:test ast) (zipmap (case-tests ast) (case-thens ast)) (:default ast))
:if
(add-conditional ssa (:test ast) {'(nil false) (:else ast)} (:then ast))
:try
(let [caught (:caught ssa)
handled (or (:name ast) (sym (:prefix ssa) 'exception))
{:as ssa target :result} (add-place ssa nil)
{:as ssa status :result} (add-place ssa false)]
(-> ssa
(dissoc :result :caught)
(add-block)
(with-default-jump (current-block ssa))
(add-branch (:body ast))
(as-> ssa
(-> ssa
(dissoc :caught)
(add-block)
(with-handler (:caught ssa) {target (sym (:prefix ssa) 'exception)})
(update :locals assoc handled target)
(add-branch (try-handler ast handled))
(restore ssa :locals))
(-> ssa
(assoc :caught caught)
(add-block)
(with-handler (:caught ssa) {status true target (sym (:prefix ssa) 'exception)})
(with-joins target (:result ssa)))
(if-some [ast (:finally ast)] (add-breaking ssa ast) ssa))
(with-place target)
(with-place status)
(add-place `(if ~status (throw ~target) ~target))))
:throw
(-> ssa
(collect add-breaking [(:exception ast)] add-many tag emit-apply met `throw)
(dissoc :result))
:monitor-enter
(collect ssa add-breaking [(:target ast)] add-many tag emit-apply met '.monitorEnter (with-meta `unsafe `{:tag Unsafe}))
:monitor-exit
(collect ssa add-breaking [(:target ast)] add-many tag emit-apply met '.monitorExit (with-meta `unsafe `{:tag Unsafe}))
:letfn
(let [prev ssa
block (current-block ssa)
symbols (map :name (:bindings ast))
{:as ssa :keys [locals]}
(reduce (fn [{:as ssa :keys [prefix places]} local]
(let [place (sym prefix 'place (count places))]
(-> ssa
(assoc-in [:locals local] place)
(assoc-in [:places place :block] block))))
ssa symbols)]
(-> (reduce (fn [ssa {:keys [name init]}]
(let [place (locals name)
ssa (-> ssa
(assoc-in [:locals (-> init :local :name)] place)
(add-closing (dissoc init :local)))]
(assoc-in ssa [:places place :init] (with-meta (:result ssa) nil))))
ssa (:bindings ast))
(update-in [:blocks block :bind] conj-vec (map locals symbols))
(add-breaking (:body ast))
(restore prev :locals))))))]
(fn [ssa ast]
(as-> (-> ssa (add-block) (add-breaking ast)) ssa
(if-some [place (:result ssa)]
(-> ssa
(with-place place)
(assoc-in [:blocks (current-block ssa) :default] {:state place})
(dissoc :result)) ssa)
(reduce (fn [ssa block]
(assoc-in ssa [:blocks block :handler]
{:state `(throw ~(sym (:prefix ssa) 'exception))}))
(dissoc ssa :caught) (:caught ssa))))))
(def span
(letfn [(with-overlap [ssa p1 p2]
(-> ssa
(update-in [:places p1 :overlaps] conj-set p2)
(update-in [:places p2 :overlaps] conj-set p1)))
(backtrack [{:as ssa :keys [places blocks]} block place]
(let [{:keys [heap origins]} (blocks block)]
(as-> ssa ssa
(update-in ssa [:blocks block :heap] conj-set place)
(reduce (fn [ssa overlap] (with-overlap ssa overlap place)) ssa heap)
(->> origins
(remove (some-fn #{(-> places place :block)} (comp place :heap blocks)))
(reduce (fn [ssa block] (backtrack ssa block place)) ssa)))))
(span-block [ssa block {:keys [read]}]
(reduce (fn [ssa place] (backtrack ssa block place)) ssa read))]
(fn [{:as ssa :keys [blocks]}]
(reduce-kv span-block ssa blocks))))
(def color
(letfn [(color-place [{:as ssa :keys [places]} place]
(let [color (or (-> places place :color)
(->> (range)
(next)
(remove (into #{}
(comp (map (comp :color places)) (remove nil?))
(-> places place :overlaps)))
(first)))]
(-> ssa
(assoc-in [:places place :color] color)
(update :colors max color))))]
(fn [{:as ssa :keys [prefix blocks]}]
(->> (range (count blocks))
(mapcat (comp :heap blocks (partial sym prefix 'block)))
(reduce color-place (assoc ssa :colors 0))))))
(def emit
(letfn [(emit-state-symbol [ssa]
(with-meta (sym (:prefix ssa) 'state) {:tag 'objects}))
(emit-fetch [ssa place]
(let [{:keys [color tag]} (-> ssa :places place)]
`(hint ~tag nil (aget ~(emit-state-symbol ssa) ~color))))
(emit-store [ssa [place value]]
`(aset ~(emit-state-symbol ssa)
~(get-in ssa [:places place :color])
~(when value `(hint nil ~(if-some [p (get-in ssa [:places value])]
(:tag p) (tag->symbol (type value))) ~value))))
(emit-jump [ssa origin {:keys [block write state]}]
(let [{:keys [heap bind]} (get-in ssa [:blocks origin])
needed (get-in ssa [:blocks block :heap] #{})]
`(do
(aset ~(emit-state-symbol ssa) 0 ~block)
~@(map (partial emit-store ssa)
(concat (->> (zipmap heap (repeat nil))
(remove (comp needed key)))
(->> (merge write (zipmap bind bind))
(filter (comp needed key)))))
~state)))
(emit-block [{:as ssa :keys [places blocks prefix]} block]
(let [{:keys [read bind test clauses default handler]} (get blocks block)
tests (keys clauses) thens (vals clauses)]
`(safe [~(sym prefix 'exception)
(let [~@(mapcat (juxt identity (partial emit-fetch ssa)) read)]
~((fn rec [bind]
(let [[items bind] (split-with symbol? bind)]
(if-some [items (seq items)]
`(let [~@(interleave items (map (comp :init places) items))]
~(rec bind))
(if-some [[items & bind] (seq bind)]
`(letfn* [~@(interleave items (map (comp :init places) items))]
~(rec bind))
(case tests
nil (emit-jump ssa block default)
[[nil false]]
`(if ~test
~(emit-jump ssa block default)
~(emit-jump ssa block (first thens)))
`(case ~test
~@(interleave tests (map (partial emit-jump ssa block) thens))
~(emit-jump ssa block default))))))) bind))]
~(emit-jump ssa block handler))))]
(fn [{:as ssa :keys [colors blocks prefix]}]
`(letfn [~@(map (fn [block] (list block [(sym prefix 'state)] (emit-block ssa block))) (keys blocks))]
(coroutine (doto (object-array ~(inc colors)) (aset 0 ~(sym prefix 'block 0))))))))
(defn compile [prefix breaks env form]
(-> {:prefix prefix
:breaks (zipmap (map (comp var-name (partial analyze env)) (keys breaks)) (vals breaks))}
(ssa (analyze env form))
(span)
(color)
(emit)))
================================================
FILE: test/cloroutine/core_test.cljc
================================================
(ns cloroutine.core-test
(:require [cloroutine.core :refer [#?(:clj cr)]]
[cloroutine.impl :refer [safe]]
[clojure.test :refer [deftest is]])
#?(:cljs (:require-macros [cloroutine.core :refer [cr]])))
#?(:clj (set! *warn-on-reflection* true))
(def check identity)
(defn nop [])
(def npe nil)
(defn run [c & xs]
(doseq [x xs]
(is (= x (c)))))
(def values [nil true false 0 "clj" :clj 'clj {:clj 42} #{"clj"} '[clj] '(clj)])
(defprotocol P (p [_]))
(deftest suite
(doseq [value values] (run (cr {} value) value))
(run (cr {} (* 6 7)) 42)
(run (cr {check nop}
(* (do (check 6) 6)
(do (check 7) 7)))
6 7 42)
(run (cr {} (if nil :then :else)) :else)
(run (cr {} (if false :then :else)) :else)
(run (cr {} (if true :then :else)) :then)
(run (cr {} (if :ok :then :else)) :then)
(run (cr {} (case nil :default)) :default)
(run (cr {} (case nil nil :clause :default)) :clause)
(run (cr {} (case :key :key :clause :default)) :clause)
(run (cr {} (case 1 1 :clause :default)) :clause)
(run (cr {} (safe [_ (try
(check (throw #?(:clj (Error. "This is fine.") :cljs "This is fine.")))
(catch #?(:clj Exception :cljs js/Error) _ :caught))]
:thrown)) :thrown)
(run (cr {check nop} (safe [_ (try (check (throw (ex-info "This is fine." {})))
(finally (check :finally)))] :thrown))
:finally :thrown)
(run (cr {check nop} (try 42 (finally (check :finally)))) :finally 42)
(run (cr {check nop} (try (check (throw (ex-info "This is fine." {})))
(catch #?(:clj Exception :cljs js/Error) _ :exception)
(catch #?(:clj Throwable :cljs :default) _ :throwable)))
:exception)
(run (cr {check nop} (safe [_ (do
(try (npe) (finally (safe [_ (npe)] (check :caught))))
(check :dead-code))] :caught)) :caught :caught)
(run (cr {} (let [a 6
b #(* a %)]
(b 7))) 42)
(run (cr {} (let [a 6
b (fn [& xs] (apply * a xs))]
(b 7))) 42)
(run (cr {} (letfn [(a [] (b))
(b [] 1)]
(a))) 1)
(run (cr {} ((cr {}))) nil)
(run (cr {} (is (= 0 0))) true)
(run (cr {} (let [a 42] (p (reify P (p [_] a))))) 42)
(run (cr {} (.substring "plop" 2)) "op")
(run (cr {} '(1 2 3)) '(1 2 3))
(run (cr {} (loop [a :a b :b n 1]
(if (pos? n)
(recur b a (dec n))
[a b]))) [:b :a])
(run (cr {} (loop [x 0
y (inc x)] y)) 1)
(apply run (cr {check nop}
(loop [x 0]
(check x)
(if (< x 100)
(recur (inc x)))))
(range 100))
(apply run (cr {check nop} (dotimes [i 10] (check i)) 10) (range 11))
(run (cr {check nop}
(let [[x y] [1 2]] (+ x y))) 3)
(run (cr {check nop}
(let [{:keys [x y] x2 :x y2 :y :as foo} {:x 1 :y 2}]
(check x)
(check (and foo y x2 y2 foo))
(+ x y))) 1 {:x 1 :y 2} 3)
(run (cr {check nop}
{:a (do (check 1) 1)
:b (do (check 2) 2)})
1 2 {:a 1 :b 2})
(run (cr {check nop}
#{(do (check 1) 1)
(do (check 2) 2)})
1 2 #{1 2})
(run (cr {check nop}
[(do (check 1) 1) (do (check 2) 2)])
1 2 [1 2])
(run (cr {} (:foo {:foo :bar})) :bar)
(run (cr {} ([1 2] 1)) 2)
(run (cr {check nop}
(loop []
(when-let [x 10]
(check (vec (for [i (range x)] i)))
(if-not x (recur))))) (range 10) nil)
(let [let* :foo]
(run (cr {} (let* [x 3] x)) 3))
(run (cr {} (loop [x 0]
(case (int x)
0 (recur (inc x))
1 42))) 42)
(run (cr {} (set! #?(:clj (.-gridx (java.awt.GridBagConstraints.))
:cljs (.-state (volatile! nil))) 42)) 42)
(run (cr {} ((comp) 42)) 42)
((cr {} (defn foo [] 41)))
(is (= (foo) 41))
#?(:cljs (run (cr {} (js->clj #js{:bar 1})) {"bar" 1}))
#?(:cljs (run (cr {} (js->clj ((fn [] #js{:bar 1})))) {"bar" 1}))
#?(:cljs (run (cr {} (js->clj #js[1 2 3])) [1 2 3]))
#?(:cljs (run (cr {} (js->clj ((fn [] #js[1 2 3])))) [1 2 3]))
#?(:cljs (run (cr {} (js* "'~{}'" "Result")) "\"Result\""))
#?(:cljs (run (cr {} (js->clj (js-obj "key" "val"))) {"key" "val"}))
)
gitextract_lllilcc9/
├── .travis.yml
├── LICENSE
├── README.md
├── deps.edn
├── doc/
│ ├── 01-generators.md
│ ├── 02-async-await.md
│ ├── 03-conduits.md
│ ├── 04-delimited-continuations.md
│ └── 05-monads.md
├── src/
│ └── cloroutine/
│ ├── core.cljc
│ ├── impl/
│ │ ├── analyze_clj.clj
│ │ └── analyze_cljs.cljc
│ └── impl.cljc
└── test/
└── cloroutine/
└── core_test.cljc
Condensed preview — 14 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (82K chars).
[
{
"path": ".travis.yml",
"chars": 408,
"preview": "dist: xenial\nsudo: true\nlanguage: clojure\nscript:\n - clojure -Aclj-test\n - clojure -Acljs-test\n - clojure -Acljs-test"
},
{
"path": "LICENSE",
"chars": 14197,
"preview": "Eclipse Public License - v 2.0\n\n THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE\n PUBLIC LICE"
},
{
"path": "README.md",
"chars": 2100,
"preview": "# cloroutine\n\nA generic, macro-based, stackless coroutine builder for Clojure and ClojureScript.\n\n[![clojars](https://im"
},
{
"path": "deps.edn",
"chars": 625,
"preview": "{:deps\n {org.clojure/tools.analyzer.jvm {:mvn/version \"1.2.3\"}}\n\n :aliases\n {:dev {:extra-paths [\"test\"]\n :extra-"
},
{
"path": "doc/01-generators.md",
"chars": 2453,
"preview": "# Generators as lazy sequences\n\nIn this guide, we'll see how coroutines can be leveraged to build immutable, lazy, possi"
},
{
"path": "doc/02-async-await.md",
"chars": 2850,
"preview": "# Future-based asynchronous processes, aka async/await\n\nIn this guide, we'll implement async/await syntax on top of `jav"
},
{
"path": "doc/03-conduits.md",
"chars": 6278,
"preview": "# Transducers revisited\n\nIn this guide, we'll reimplement [clj-conduit](https://github.com/hypirion/clj-conduit) using `"
},
{
"path": "doc/04-delimited-continuations.md",
"chars": 3040,
"preview": "# Delimited continuations\n\nIn this guide, we'll implement a clojure version of scheme's `shift`/`reset` control flow ope"
},
{
"path": "doc/05-monads.md",
"chars": 4825,
"preview": "# Monads\n\nA monad refers to a category of values associated with a pair of functions `[unit bind]` such that :\n* `(unit "
},
{
"path": "src/cloroutine/core.cljc",
"chars": 1632,
"preview": "(ns cloroutine.core (:require [cloroutine.impl :as i]))\n\n(defmacro\n ^{:arglists '([breaks & body]) :doc \"\nBuilds a coro"
},
{
"path": "src/cloroutine/impl/analyze_clj.clj",
"chars": 903,
"preview": "(ns cloroutine.impl.analyze-clj\n (:require [clojure.tools.analyzer.jvm :as clj])\n (:import (clojure.lang Compiler$Loca"
},
{
"path": "src/cloroutine/impl/analyze_cljs.cljc",
"chars": 285,
"preview": "(ns cloroutine.impl.analyze-cljs\n (:require [cljs.analyzer]\n [cljs.env]))\n\n(defn analyze [env form]\n (bindi"
},
{
"path": "src/cloroutine/impl.cljc",
"chars": 34968,
"preview": "(ns ^:no-doc cloroutine.impl\n (:refer-clojure :exclude [compile])\n (:require #?(:cljs [cloroutine.impl.analyze-cljs :a"
},
{
"path": "test/cloroutine/core_test.cljc",
"chars": 4504,
"preview": "(ns cloroutine.core-test\n (:require [cloroutine.core :refer [#?(:clj cr)]]\n [cloroutine.impl :refer [safe]]\n"
}
]
About this extraction
This page contains the full source code of the leonoel/cloroutine GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 14 files (77.2 KB), approximately 19.3k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.