Skip to content

Commit 559bfb3

Browse files
jnapejnape
committed
Adding SafeT, a stack-safe transformer for any MonadRec
1 parent 99b8d48 commit 559bfb3

File tree

4 files changed

+391
-0
lines changed

4 files changed

+391
-0
lines changed

‎src/main/java/com/jnape/palatable/lambda/functions/specialized/Pure.java

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,4 +33,16 @@ public interface Pure<F extends Functor<?, ? extends F>> {
3333
static <F extends Functor<?, ? extends F>> Pure<F> pure(Pure<F> pure) {
3434
return pure;
3535
}
36+
37+
/**
38+
* Extract an {@link Applicative Applicative's} {@link Applicative#pure(Object) pure} implementation to an instance
39+
* of {@link Pure}.
40+
*
41+
* @param app the {@link Applicative}
42+
* @param <F> the witness
43+
* @return the {@link Pure}
44+
*/
45+
static <F extends Applicative<?, ? extends F>> Pure<F> of(Applicative<?, ? extends F> app) {
46+
return app::pure;
47+
}
3648
}

‎src/main/java/com/jnape/palatable/lambda/monad/MonadRec.java

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,9 @@
1313
/**
1414
* A class of {@link Monad monads} that offer a stack-safe interface for performing arbitrarily many
1515
* {@link Monad#flatMap(Fn1) flatmap-like} operations via {@link MonadRec#trampolineM(Fn1)}.
16+
* <p>
17+
* Inspired by Phil Freeman's paper
18+
* <a href="http://functorial.com/stack-safety-for-free/index.pdf" target="_blank">_Stack Safety for Free_</a>
1619
*
1720
* @param <A> the carrier type
1821
* @param <M> the {@link MonadRec witness}

‎src/main/java/com/jnape/palatable/lambda/monad/SafeT.java

Lines changed: 300 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,300 @@
1+
package com.jnape.palatable.lambda.monad;
2+
3+
import com.jnape.palatable.lambda.adt.Either;
4+
import com.jnape.palatable.lambda.adt.coproduct.CoProduct2;
5+
import com.jnape.palatable.lambda.functions.Fn1;
6+
import com.jnape.palatable.lambda.functions.recursion.RecursiveResult;
7+
import com.jnape.palatable.lambda.functions.recursion.Trampoline;
8+
import com.jnape.palatable.lambda.functions.specialized.Lift;
9+
import com.jnape.palatable.lambda.functions.specialized.Pure;
10+
import com.jnape.palatable.lambda.functor.Applicative;
11+
import com.jnape.palatable.lambda.functor.builtin.Lazy;
12+
import com.jnape.palatable.lambda.monad.transformer.MonadT;
13+
14+
import static com.jnape.palatable.lambda.adt.Either.left;
15+
import static com.jnape.palatable.lambda.adt.Either.right;
16+
import static com.jnape.palatable.lambda.functions.recursion.RecursiveResult.recurse;
17+
import static com.jnape.palatable.lambda.functions.recursion.RecursiveResult.terminate;
18+
19+
/**
20+
* A stack-safe {@link MonadT monad transformer} that can safely interpret deeply nested left- or right-associated
21+
* binds for any {@link MonadRec}.
22+
* <p>
23+
* Example:
24+
* <pre>
25+
* {@code
26+
* Times.<Fn1<Integer, Integer>>times(100_000, f -> f.fmap(x -> x + 1), id()).apply(0); // stack-overflow
27+
* Times.<SafeT<Fn1<Integer, ?>, Integer>>times(100_000, f -> f.fmap(x -> x + 1), safeT(id()))
28+
* .<Fn1<Integer, Integer>>runSafeT()
29+
* .apply(0); // 100_000
30+
* }
31+
* </pre>
32+
* <p>
33+
* Inspired by Phil Freeman's paper
34+
* <a href="http://functorial.com/stack-safety-for-free/index.pdf">Stack Safety for Free</a>.
35+
*
36+
* @param <M> the {@link MonadRec} instance
37+
* @param <A> the carrier type
38+
*/
39+
public final class SafeT<M extends MonadRec<?, M>, A> implements
40+
MonadT<M, A, SafeT<M, ?>, SafeT<?, ?>> {
41+
42+
private final Body<M, A> body;
43+
private final Pure<M> pureM;
44+
45+
private SafeT(Body<M, A> body, Pure<M> pureM) {
46+
this.body = body;
47+
this.pureM = pureM;
48+
}
49+
50+
/**
51+
* Recover the full structure of the embedded {@link Monad} in a stack-safe way.
52+
*
53+
* @param <MA> the witnessed target type
54+
* @return the embedded {@link Monad}
55+
*/
56+
public <MA extends MonadRec<A, M>> MA runSafeT() {
57+
return body.resume().match(
58+
fFree -> fFree.trampolineM(freeF -> freeF.resume().match(
59+
monadRec -> monadRec.fmap(RecursiveResult::recurse),
60+
a -> pureM.<A, MonadRec<A, M>>apply(a).fmap(RecursiveResult::terminate))).coerce(),
61+
pureM::apply);
62+
}
63+
64+
/**
65+
* {@inheritDoc}
66+
*/
67+
@Override
68+
public <B> SafeT<M, B> fmap(Fn1<? super A, ? extends B> fn) {
69+
return MonadT.super.<B>fmap(fn).coerce();
70+
}
71+
72+
/**
73+
* {@inheritDoc}
74+
*/
75+
@Override
76+
public <B, N extends MonadRec<?, N>> SafeT<N, B> lift(MonadRec<B, N> nb) {
77+
return liftSafeT().apply(nb);
78+
}
79+
80+
/**
81+
* {@inheritDoc}
82+
*/
83+
@Override
84+
public <B> SafeT<M, B> flatMap(Fn1<? super A, ? extends Monad<B, SafeT<M, ?>>> f) {
85+
return new SafeT<>(Body.suspend(body, a -> f.apply(a).<SafeT<M, B>>coerce().body), pureM);
86+
}
87+
88+
/**
89+
* {@inheritDoc}
90+
*/
91+
@Override
92+
public <B> SafeT<M, B> zip(Applicative<Fn1<? super A, ? extends B>, SafeT<M, ?>> appFn) {
93+
return body.resume()
94+
.match(mBodyA -> appFn.<SafeT<M, Fn1<? super A, ? extends B>>>coerce().body.resume()
95+
.match(mBodyF -> new SafeT<>(Body.more(mBodyA.zip(mBodyF.fmap(
96+
bodyF -> bodyA -> new SafeT<>(bodyA, pureM).zip(new SafeT<>(bodyF, pureM)).body))), pureM),
97+
f -> new SafeT<>(Body.more(mBodyA.fmap(b -> Body.suspend(
98+
b, a -> Body.done(f.apply(a))))), pureM)),
99+
a -> appFn.<SafeT<M, Fn1<? super A, ? extends B>>>coerce().body.resume()
100+
.match(mBodyF -> new SafeT<>(new Body.More<>(mBodyF.fmap(
101+
body -> new SafeT<>(body, pureM).<B>fmap(f -> f.apply(a)).body)), pureM),
102+
f -> pure(f.apply(a))));
103+
}
104+
105+
/**
106+
* {@inheritDoc}
107+
*/
108+
@Override
109+
public <B> Lazy<SafeT<M, B>> lazyZip(
110+
Lazy<? extends Applicative<Fn1<? super A, ? extends B>, SafeT<M, ?>>> lazyAppFn) {
111+
return MonadT.super.lazyZip(lazyAppFn).fmap(Applicative<B, SafeT<M, ?>>::coerce);
112+
}
113+
114+
/**
115+
* {@inheritDoc}
116+
*/
117+
@Override
118+
public <B> SafeT<M, B> discardL(Applicative<B, SafeT<M, ?>> appB) {
119+
return MonadT.super.discardL(appB).coerce();
120+
}
121+
122+
/**
123+
* {@inheritDoc}
124+
*/
125+
@Override
126+
public <B> SafeT<M, A> discardR(Applicative<B, SafeT<M, ?>> appB) {
127+
return MonadT.super.discardR(appB).coerce();
128+
}
129+
130+
/**
131+
* {@inheritDoc}
132+
*/
133+
@Override
134+
public <B> SafeT<M, B> pure(B b) {
135+
return pureSafeT(pureM).apply(b);
136+
}
137+
138+
/**
139+
* {@inheritDoc}
140+
*/
141+
@Override
142+
public <B> SafeT<M, B> trampolineM(Fn1<? super A, ? extends MonadRec<RecursiveResult<A, B>, SafeT<M, ?>>> bounce) {
143+
return flatMap(bounce.fmap(mab -> mab.flatMap(aOrB -> aOrB
144+
.match(a -> mab.pure(a).trampolineM(bounce), Pure.of(mab)::apply))));
145+
}
146+
147+
/**
148+
* Lift any <code>{@link MonadRec MonadRec}&lt;A, M&gt;</code> into a <code>{@link SafeT SafeT}&lt;M, A&gt;</code>.
149+
*
150+
* @param ma the {@link MonadRec MonadRec}&lt;A, M&gt;
151+
* @param <M> the {@link MonadRec} witness
152+
* @param <A> the carrier type
153+
* @return the new {@link SafeT}
154+
*/
155+
public static <M extends MonadRec<?, M>, A> SafeT<M, A> safeT(MonadRec<A, M> ma) {
156+
return new SafeT<>(new Body.More<>(ma.fmap(Body.Done::new)), Pure.of(ma));
157+
}
158+
159+
/**
160+
* The canonical {@link Pure} instance for {@link SafeT}.
161+
*
162+
* @param pureM the argument {@link Monad} {@link Pure}
163+
* @param <M> the argument {@link Monad} witness
164+
* @return the {@link Pure} instance
165+
*/
166+
public static <M extends MonadRec<?, M>> Pure<SafeT<M, ?>> pureSafeT(Pure<M> pureM) {
167+
return new Pure<SafeT<M, ?>>() {
168+
@Override
169+
public <A> SafeT<M, A> checkedApply(A a) throws Throwable {
170+
return safeT(pureM.<A, MonadRec<A, M>>apply(a));
171+
}
172+
};
173+
}
174+
175+
/**
176+
* {@link Lift} for {@link SafeT}.
177+
*
178+
* @return the {@link Monad} lifted into {@link SafeT}
179+
*/
180+
public static Lift<SafeT<?, ?>> liftSafeT() {
181+
return SafeT::safeT;
182+
}
183+
184+
private abstract static class Body<M extends MonadRec<?, M>, A> implements
185+
CoProduct2<Either<MonadRec<Body<M, A>, M>, A>, Body.Suspended<M, ?, A>, Body<M, A>> {
186+
187+
private Body() {
188+
}
189+
190+
public abstract Either<MonadRec<Body<M, A>, M>, A> resume();
191+
192+
private static <M extends MonadRec<?, M>, A> Body<M, A> done(A a) {
193+
return new Done<>(a);
194+
}
195+
196+
private static <M extends MonadRec<?, M>, A> Body<M, A> more(MonadRec<Body<M, A>, M> mb) {
197+
return new More<>(mb);
198+
}
199+
200+
private static <M extends MonadRec<?, M>, A, B> Body<M, B> suspend(Body<M, A> freeA, Fn1<A, Body<M, B>> fn) {
201+
return new SafeT.Body.Suspended<>(freeA, fn);
202+
}
203+
204+
private static final class Done<M extends MonadRec<?, M>, A> extends Body<M, A> {
205+
private final A a;
206+
207+
private Done(A a) {
208+
this.a = a;
209+
}
210+
211+
@Override
212+
public <R> R match(Fn1<? super Either<MonadRec<Body<M, A>, M>, A>, ? extends R> aFn,
213+
Fn1<? super SafeT.Body.Suspended<M, ?, A>, ? extends R> bFn) {
214+
return aFn.apply(right(a));
215+
}
216+
217+
@Override
218+
public Either<MonadRec<Body<M, A>, M>, A> resume() {
219+
return right(a);
220+
}
221+
}
222+
223+
private static final class More<M extends MonadRec<?, M>, A> extends Body<M, A> {
224+
private final MonadRec<Body<M, A>, M> mfa;
225+
226+
private More(MonadRec<Body<M, A>, M> mfa) {
227+
this.mfa = mfa;
228+
}
229+
230+
@Override
231+
public <R> R match(Fn1<? super Either<MonadRec<Body<M, A>, M>, A>, ? extends R> aFn,
232+
Fn1<? super SafeT.Body.Suspended<M, ?, A>, ? extends R> bFn) {
233+
return aFn.apply(left(mfa));
234+
}
235+
236+
@Override
237+
public Either<MonadRec<Body<M, A>, M>, A> resume() {
238+
return left(mfa);
239+
}
240+
}
241+
242+
private static final class Suspended<M extends MonadRec<?, M>, A, B> extends Body<M, B> {
243+
private final Body<M, A> source;
244+
private final Fn1<A, Body<M, B>> f;
245+
246+
private Suspended(Body<M, A> source, Fn1<A, Body<M, B>> f) {
247+
this.source = source;
248+
this.f = f;
249+
}
250+
251+
public Either<MonadRec<Body<M, B>, M>, B> resume() {
252+
Φ<M, B, RecursiveResult<Body<M, B>, Either<MonadRec<Body<M, B>, M>, B>>> phi =
253+
new Φ<M, B, RecursiveResult<Body<M, B>, Either<MonadRec<Body<M, B>, M>, B>>>() {
254+
@Override
255+
public <Z> RecursiveResult<Body<M, B>, Either<MonadRec<Body<M, B>, M>, B>> apply(
256+
Body<M, Z> source, Fn1<Z, Body<M, B>> f) {
257+
return source.match(
258+
e -> e.match(more -> terminate(left(more.fmap(body -> suspend(body, f)))),
259+
z -> recurse(f.apply(z))),
260+
associateRight(f));
261+
}
262+
};
263+
return Trampoline.<Body<M, B>, Either<MonadRec<Body<M, B>, M>, B>>trampoline(
264+
free -> free.match(RecursiveResult::terminate, suspended -> suspended.eliminate(phi)),
265+
this);
266+
}
267+
268+
@Override
269+
public <R> R match(Fn1<? super Either<MonadRec<Body<M, B>, M>, B>, ? extends R> aFn,
270+
Fn1<? super Suspended<M, ?, B>, ? extends R> bFn) {
271+
return bFn.apply(this);
272+
}
273+
274+
private <Z> Fn1<Suspended<M, ?, Z>, RecursiveResult<Body<M, B>, Either<MonadRec<Body<M, B>, M>, B>>>
275+
associateRight(Fn1<Z, Body<M, B>> f) {
276+
Φ<M, Z, RecursiveResult<Body<M, B>, Either<MonadRec<Body<M, B>, M>, B>>> phi =
277+
new Φ<M, Z, RecursiveResult<Body<M, B>, Either<MonadRec<Body<M, B>, M>, B>>>() {
278+
@Override
279+
public <Y> RecursiveResult<Body<M, B>, Either<MonadRec<Body<M, B>, M>, B>> apply(
280+
Body<M, Y> source,
281+
Fn1<Y, Body<M, Z>> g) {
282+
return recurse(suspend(source, x -> suspend(g.apply(x), f)));
283+
}
284+
};
285+
286+
return suspended -> suspended.eliminate(phi);
287+
}
288+
289+
@SuppressWarnings("NonAsciiCharacters")
290+
private <R> R eliminate(Φ<M, B, R> Φ) {
291+
return Φ.apply(source, f);
292+
}
293+
294+
@SuppressWarnings("NonAsciiCharacters")
295+
private interface Φ<M extends MonadRec<?, M>, B, R> {
296+
<A> R apply(Body<M, A> source, Fn1<A, Body<M, B>> fn);
297+
}
298+
}
299+
}
300+
}

0 commit comments

Comments
 (0)