day-kt

Day.kt

package com.github.kaishh.day

import arrow.*
import arrow.core.*
import arrow.data.*
import arrow.syntax.function.*
import arrow.instances.*
import arrow.typeclasses.*

/**
 * Have a nice [Day]!
 */
@higherkind
data class Day<F, G, C> internal constructor(val f: Kind<F, *>, val g: Kind<G, *>, val c: (Any?, Any?) -> C)
    : DayOf<F, G, C>, DayKindedJ<F, G, C> {

    fun extract(CF: Comonad<F>, CG: Comonad<G>): C =
            CF.run {
                CG.run {
                    c(f.extract(), g.extract())
                }
            }

    fun <D> coflatMap(CF: Comonad<F>, CG: Comonad<G>, f: (Day<F, G, C>) -> D): Day<F, G, D> =
            duplicate(CF, CG).map(f)

    fun duplicate(CF: Comonad<F>, CG: Comonad<G>): Day<F, G, Day<F, G, C>> =
            CF.run {
                CG.run {
                    Day.invoke(f.duplicate(), g.duplicate()) { f0, g0 -> Day(f0, g0, c)}
                }
            }

    fun <D> map(f: (C) -> D): Day<F, G, D> =
            Day(this.f, g, c.paired().k().map(f).f.unpaired())

    companion object {
        operator fun <F, G> invoke(): DayPartialApply<F, G> = DayPartialApply()

        @Suppress("UNCHECKED_CAST")
        operator fun <F, G, A, B, C> invoke(f: Kind<F, A>, g: Kind<G, B>, c: (A, B) -> C): Day<F, G, C> = Day(f, g, c as (Any?, Any?) -> C)

        fun <F, G, A, B> tupled(f: Kind<F, A>, g: Kind<G, B>): Day<F, G, Tuple2<A, B>> = invoke(f, g) { a, b -> Tuple2(a, b) }

        class DayPartialApply<F, G> {
            @Suppress("UNCHECKED_CAST")
            operator fun <A, B, C> invoke(f: Kind<F, A>, g: Kind<G, B>, c: (A, B) -> C): Day<F, G, C> = Day(f, g, c as (Any?, Any?) -> C)
        }
    }
}

fun <F, G> Day.Companion.functor(): DayFunctorInstance<F, G> =
        object : DayFunctorInstance<F, G> {}

fun <F, G> Day.Companion.comonad(CF: Comonad<F>, CG: Comonad<G>): DayComonadInstance<F, G> =
        object : DayComonadInstance<F, G> {
            override fun CF(): Comonad<F> = CF
            override fun CG(): Comonad<G> = CG
        }

interface DayFunctorInstance<F, G> : Functor<DayPartialOf<F, G>> {
    override fun <A, B> Kind<DayPartialOf<F, G>, A>.map(f: (A) -> B): Kind<DayPartialOf<F, G>, B> = fix().map(f)
}

interface DayComonadInstance<F, G> : Comonad<DayPartialOf<F, G>> {
    fun CF(): Comonad<F>
    fun CG(): Comonad<G>

    override fun <A> Kind<DayPartialOf<F, G>, A>.extract(): A = fix().extract(CF(), CG())

    override fun <A, B> Kind<DayPartialOf<F, G>, A>.coflatMap(f: (Kind<DayPartialOf<F, G>, A>) -> B): Kind<DayPartialOf<F, G>, B> = fix().coflatMap(CF(), CG(), f)

    override fun <A> Kind<DayPartialOf<F, G>, A>.duplicate(): Kind<DayPartialOf<F, G>, Kind<DayPartialOf<F, G>, A>> = fix().duplicate(CF(), CG())

    override fun <A, B> Kind<DayPartialOf<F, G>, A>.map(f: (A) -> B): Kind<DayPartialOf<F, G>, B> = fix().map(f)
}

class DayContext<F, G>(val CF: Comonad<F>, val CG: Comonad<G>) : DayComonadInstance<F, G> {
    override fun CF(): Comonad<F> = CF
    override fun CG(): Comonad<G> = CG
}

class DayContextPartiallyApplied<F, G>(val CF: Comonad<F>, val CG: Comonad<G>) {
    infix fun <A> extensions(f: DayContext<F, G>.() -> A): A =
            f(DayContext(CF, CG))
}

fun <F, G> ForDay(CF: Comonad<F>, CG: Comonad<G>): DayContextPartiallyApplied<F, G> =
        DayContextPartiallyApplied(CF, CG)

typealias Interp3<F, G, H> = DayPartialOf<F, DayPartialOf<G, H>>

typealias TripleDay<F> = Interp3<F, F, F>

object X {
    fun i(): Int {
        val z: Kind<TripleDay<ForNonEmptyList>, Tuple2<Int, Tuple2<Int, Int>>> =
                Day.tupled(NonEmptyList.just(5), Day.tupled(NonEmptyList.just(10), NonEmptyList.just(15)))

        val r: Kind<TripleDay<ForNonEmptyList>, Int> = Day.functor<ForNonEmptyList, DayPartialOf<ForNonEmptyList, ForNonEmptyList>>().run {
            z.map { (x, y0) -> y0.let { (y, z) -> x + y + z} }
        }

        return ForDay(NonEmptyList.comonad(), Day.comonad(NonEmptyList.comonad(), NonEmptyList.comonad())) extensions {
            r.extract()
        }
    }
}