Kleisli and EitherT extra instances and tests + some fixes

kategory/src/main/kotlin/kategory/data/EitherT.kt

@@ -78,3 +78,51 @@ data class EitherT<F, A, B>(val MF: Monad<F>, val value: HK<F, Either<A, B>>) :
         return GA.map(fa, { EitherT(MF, MF.map(it.lower(), { it.ev() })) })
     }
 }
+
+class EitherTInstances<F, L>(val MF : Monad<F>) : EitherTMonadError<F, L> {
+    override fun MF(): Monad<F> = MF
+}
+
+interface EitherTMonad<F, L> : Monad<EitherTF<F, L>> {
+
+    fun MF() : Monad<F>
+
+    override fun <A> pure(a: A): EitherT<F, L, A> =
+            EitherT(MF(), MF().pure(Either.Right(a)))
+
+    override fun <A, B> map(fa: EitherTKind<F, L, A>, f: (A) -> B): EitherT<F, L, B> =
+            fa.ev().map { f(it) }
+
+    override fun <A, B> flatMap(fa: EitherTKind<F, L, A>, f: (A) -> EitherTKind<F, L, B>): EitherT<F, L, B> =
+            fa.ev().flatMap { f(it).ev() }
+
+    override fun <A, B> tailRecM(a: A, f: (A) -> HK<EitherTF<F, L>, Either<A, B>>): EitherT<F, L, B> =
+            EitherT(MF(), MF().tailRecM(a, {
+                MF().map(f(it).ev().value) { recursionControl ->
+                    when (recursionControl) {
+                        is Either.Left<L> -> Either.Right(Either.Left(recursionControl.a))
+                        is Either.Right<Either<A, B>> ->
+                            when (recursionControl.b) {
+                                is Either.Left<A> -> Either.Left(recursionControl.b.a)
+                                is Either.Right<B> -> Either.Right(Either.Right(recursionControl.b.b))
+                            }
+                    }
+                }
+            }))
+
+}
+
+interface EitherTMonadError<F, E> : EitherTMonad<F, E>, MonadError<EitherTF<F, E>, E> {
+
+    override fun <A> handleErrorWith(fa: EitherTKind<F, E, A>, f: (E) -> EitherTKind<F, E, A>): EitherT<F, E, A> =
+            EitherT(MF(), MF().flatMap(fa.ev().value, {
+                when (it) {
+                    is Either.Left -> f(it.a).ev().value
+                    is Either.Right -> MF().pure(it)
+                }
+            }))
+
+    override fun <A> raiseError(e: E): EitherT<F, E, A> =
+            EitherT(MF(), MF().pure(Either.Left(e)))
+
+}

kategory/src/main/kotlin/kategory/data/Kleisli.kt

@@ -2,9 +2,8 @@ package kategory
 
 typealias KleisliTKind<F, A, B> = HK3<Kleisli.F, F, A, B>
 typealias KleisliF<F> = HK<Kleisli.F, F>
-
+typealias KleisliFD<F, D> = HK2<Kleisli.F, F, D>
 typealias KleisliFun<F, D, A> = (D) -> HK<F, A>
-
 typealias ReaderT<F, D, A> = Kleisli<F, D, A>
 
 fun <F, D, A> KleisliTKind<F, D, A>.ev(): Kleisli<F, D, A> =
@@ -54,3 +53,54 @@ class Kleisli<F, D, A>(val MF: Monad<F>, val run: KleisliFun<F, D, A>) : Kleisli
 
 inline fun <reified F, D, A> Kleisli<F, D, Kleisli<F, D, A>>.flatten(): Kleisli<F, D, A> =
         flatMap({ it })
+
+class KleisliInstances<F, D, E>(val FME: MonadError<F, E>) : KleisliMonadReader<F, D>, KleisliMonadError<F, D, E> {
+    override fun FM(): Monad<F> = FME
+
+    override fun FME(): MonadError<F, E> = FME
+}
+
+interface KleisliMonadReader<F, D> : MonadReader<KleisliFD<F, D>, D>, KleisliMonad<F, D> {
+
+    override fun FM(): Monad<F>
+
+    override fun ask(): Kleisli<F, D, D> =
+            Kleisli(FM(), { FM().pure(it) })
+
+    override fun <A> local(f: (D) -> D, fa: HK<KleisliFD<F, D>, A>): Kleisli<F, D, A> =
+            fa.ev().local(f)
+}
+
+interface KleisliMonad<F, D> : Monad<KleisliFD<F, D>> {
+
+    fun FM(): Monad<F>
+
+    override fun <A, B> flatMap(fa: HK<KleisliFD<F, D>, A>, f: (A) -> HK<KleisliFD<F, D>, B>): Kleisli<F, D, B> =
+            fa.ev().flatMap(f.andThen { it.ev() })
+
+    override fun <A, B> map(fa: HK<KleisliFD<F, D>, A>, f: (A) -> B): Kleisli<F, D, B> =
+            fa.ev().map(f)
+
+    override fun <A, B> product(fa: HK<KleisliFD<F, D>, A>, fb: HK<KleisliFD<F, D>, B>): Kleisli<F, D, Tuple2<A, B>> =
+            Kleisli(FM(), { FM().product(fa.ev().run(it), fb.ev().run(it)) })
+
+    override fun <A, B> tailRecM(a: A, f: (A) -> HK<KleisliFD<F, D>, Either<A, B>>): Kleisli<F, D, B> =
+            Kleisli(FM(), { b -> FM().tailRecM(a, { f(it).ev().run(b) }) })
+
+    override fun <A> pure(a: A): Kleisli<F, D, A> =
+            Kleisli(FM(), { FM().pure(a) })
+}
+
+interface KleisliMonadError<F, D, E> : MonadError<KleisliFD<F, D>, E>, KleisliMonad<F, D> {
+
+    fun FME(): MonadError<F, E>
+
+    override fun <A> handleErrorWith(fa: HK<KleisliFD<F, D>, A>, f: (E) -> HK<KleisliFD<F, D>, A>): Kleisli<F, D, A> =
+            Kleisli(FME(), {
+                FME().handleErrorWith(fa.ev().run(it), { e: E -> f(e).ev().run(it) })
+            })
+
+    override fun <A> raiseError(e: E): Kleisli<F, D, A> =
+            Kleisli(FME(), { FME().raiseError(e) })
+
+}

kategory/src/main/kotlin/kategory/typeclasses/ApplicativeError.kt

@@ -13,6 +13,16 @@ interface ApplicativeError<F, E> : Applicative<F>, Typeclass {
             handleErrorWith(map(fa) { Either.Right(it) }) {
                 pure(Either.Left(it))
             }
+
+    fun <A> fromEither(fab: Either<E, A>): HK<F, A> =
+            fab.fold({ raiseError<A>(it) }, { pure(it) })
+
+    fun <A> catch(f: () -> A, recover: (Throwable) -> E): HK<F, A> =
+            try {
+                pure(f())
+            } catch (t: Throwable) {
+                raiseError<A>(recover(t))
+            }
 }
 
 fun <F, A> ApplicativeError<F, Throwable>.catch(f: () -> A): HK<F, A> =
@@ -24,4 +34,4 @@ fun <F, A> ApplicativeError<F, Throwable>.catch(f: () -> A): HK<F, A> =
         }
 
 inline fun <reified F, reified E> applicativeError(): ApplicativeError<F, E> =
-        instance(InstanceParametrizedType(Monad::class.java, listOf(F::class.java, E::class.java)))
+        instance(InstanceParametrizedType(ApplicativeError::class.java, listOf(F::class.java, E::class.java)))

kategory/src/main/kotlin/kategory/typeclasses/MonadError.kt

@@ -38,4 +38,4 @@ fun <F, B> MonadError<F, Throwable>.bindingE(c: suspend MonadErrorContinuation<F
 }
 
 inline fun <reified F, reified E> monadError(): MonadError<F, E> =
-        instance(InstanceParametrizedType(Functor::class.java, listOf(F::class.java, E::class.java)))
+        instance(InstanceParametrizedType(MonadError::class.java, listOf(F::class.java, E::class.java)))

kategory/src/main/kotlin/kategory/typeclasses/MonadReader.kt

@@ -0,0 +1,15 @@
+package kategory
+
+interface MonadReader<F, D> : Monad<F> {
+    /** Get the environment */
+    fun ask(): HK<F, D>
+
+    /** Modify the environment */
+    fun <A> local(f: (D) -> D, fa: HK<F, A>): HK<F, A>
+
+    /** Retrieves a function of the environment */
+    fun <A> reader(f: (D) -> A): HK<F, A> = map(ask(), f)
+}
+
+inline fun <reified F, reified D> monadReader(): MonadReader<F, D> =
+        instance(InstanceParametrizedType(MonadReader::class.java, listOf(F::class.java, D::class.java)))

kategory/src/main/kotlin/kategory/typeclasses/Typeclass.kt

@@ -65,42 +65,6 @@ class InstanceParametrizedType(val raw: Type, val typeArgs: List<Type>) : Parame
                 hashCode(rawType)
     }
 
-    override fun toString(): String {
-        val sb = StringBuilder()
-
-        if (ownerType != null) {
-            if (ownerType is Class<*>)
-                sb.append((ownerType as Class<*>).name)
-            else
-                sb.append(ownerType.toString())
-
-            sb.append(".")
-
-            if (ownerType is ParameterizedType) {
-                // Find simple name of nested type by removing the
-                // shared prefix with owner.
-                sb.append(rawType.typeName.replace((ownerType as ParameterizedType).rawType.typeName + "$",
-                        ""))
-            } else
-                sb.append(rawType.typeName)
-        } else
-            sb.append(rawType.typeName)
-
-        if (actualTypeArguments.isNotEmpty()) {
-            sb.append("<")
-            var first = true
-            for (t in actualTypeArguments) {
-                if (!first)
-                    sb.append(", ")
-                sb.append(t.typeName)
-                first = false
-            }
-            sb.append(">")
-        }
-
-        return sb.toString()
-    }
-
     fun hashCode(o: Any?): Int {
         return o?.hashCode() ?: 0
     }

kategory/src/test/kotlin/kategory/data/EitherTTest.kt

@@ -10,7 +10,7 @@ import org.junit.runner.RunWith
 class EitherTTest : UnitSpec() {
     init {
 
-        testLaws(MonadLaws.laws(EitherTMonad<Id.F, Int>(), Eq.any()))
+        testLaws(MonadErrorLaws.laws(EitherTInstances<Id.F, Throwable>(Id), Eq.any()))
 
         "map should modify value" {
             forAll { a: String ->
@@ -165,13 +165,13 @@ class EitherTTest : UnitSpec() {
             forAll { a: Int ->
                 val x = { b: Int -> EitherT.pure<Id.F, Int, Int>(b * a) }
                 val option = EitherT.pure<Id.F, Int, Int>(a)
-                option.flatMap(x) == EitherTMonad<Id.F, Int>(Id).flatMap(option, x)
+                option.flatMap(x) == EitherTInstances<Id.F, Int>(Id).flatMap(option, x)
             }
         }
 
         "EitherTMonad#tailRecM should execute and terminate without blowing up the stack" {
             forAll { a: Int ->
-                val value: EitherT<Id.F, Int, Int> = EitherTMonad<Id.F, Int>(Id).tailRecM(a) { b ->
+                val value: EitherT<Id.F, Int, Int> = EitherTInstances<Id.F, Int>(Id).tailRecM(a) { b ->
                     EitherT.pure<Id.F, Int, Either<Int, Int>>(Either.Right(b * a))
                 }
                 val expected = EitherT.pure<Id.F, Int, Int>(a * a)
@@ -180,7 +180,7 @@ class EitherTTest : UnitSpec() {
             }
 
             forAll(Gen.oneOf(listOf(10000))) { limit: Int ->
-                val value: EitherT<Id.F, Int, Int> = EitherTMonad<Id.F, Int>(Id).tailRecM(0) { current ->
+                val value: EitherT<Id.F, Int, Int> = EitherTInstances<Id.F, Int>(Id).tailRecM(0) { current ->
                     if (current == limit)
                         EitherT.left(current)
                     else
@@ -226,7 +226,7 @@ class EitherTTest : UnitSpec() {
         }
 
         "EitherTMonad#binding should for comprehend over option" {
-            val M = EitherTMonad<NonEmptyList.F, Int>(NonEmptyList)
+            val M = EitherTInstances<NonEmptyList.F, Int>(NonEmptyList)
             val result = M.binding {
                 val x = !M.pure(1)
                 val y = M.pure(1).bind()
@@ -237,13 +237,13 @@ class EitherTTest : UnitSpec() {
         }
 
         "Cartesian builder should build products over option" {
-            EitherTMonad<Id.F, Int>(Id).map(EitherT.pure(1), EitherT.pure("a"), EitherT.pure(true), { (a, b, c) ->
+            EitherTInstances<Id.F, Int>(Id).map(EitherT.pure(1), EitherT.pure("a"), EitherT.pure(true), { (a, b, c) ->
                 "$a $b $c"
             }) shouldBe EitherT.pure<Id.F, Int, String>("1 a true")
         }
 
         "Cartesian builder works inside for comprehensions" {
-            val M = EitherTMonad<NonEmptyList.F, Int>(NonEmptyList)
+            val M = EitherTInstances<NonEmptyList.F, Int>(NonEmptyList)
             val result = M.binding {
                 val (x, y, z) = !M.tupled(M.pure(1), M.pure(1), M.pure(1))
                 val a = M.pure(1).bind()

kategory/src/test/kotlin/kategory/data/KleisliTest.kt

@@ -7,6 +7,15 @@ import org.junit.runner.RunWith
 @RunWith(KTestJUnitRunner::class)
 class KleisliTest : UnitSpec() {
     init {
+
+        val instances = KleisliInstances<Try.F, Int, Throwable>(Try)
+
+        testLaws(MonadErrorLaws.laws(instances, object : Eq<KleisliTKind<Try.F, Int, Int>> {
+            override fun eqv(a: KleisliTKind<Try.F, Int, Int>, b: KleisliTKind<Try.F, Int, Int>): Boolean =
+                a.ev().run(1) == b.ev().run(1)
+
+        }))
+
         "andThen should continue sequence" {
             val kleisli: Kleisli<Id.F, Int, Int> = Kleisli({ a: Int -> Id(a) })