Typescript Free Monad

Disk.ts

import { Tagged } from "@effect-ts/core/Case"
import * as P from "../../prelude"
import * as Free from "./FreeMonad"
import { makeFree } from "./FreeMonad"
import { identity, pipe } from "@effect-ts/core/Function"
import * as T from "@effect-ts/core/Effect"
import { matchTag } from "@effect-ts/core/Utils"
import * as FS from "fs"
import * as Ei from "@effect-ts/core/Either"

export class Read<A> extends Tagged("Read")<{ path: string; _A: (a: string) => A }> {}

export class Write<A> extends Tagged("Write")<{
	path: string
	content: string
	_A: (a: undefined) => A
}> {}

export class Delete<A> extends Tagged("Delete")<{ path: string; _A: (a: undefined) => A }> {}

export type Disk<A> = Read<A> | Write<A> | Delete<A>

export interface DiskF extends P.HKT {
	readonly type: Disk<this["A"]>
}

const { chain, map, lift, pure } = makeFree<DiskF>()

export { chain, map }

export const read = (path: string) => lift(new Read({ path, _A: identity }))

export const write = (path: string, content: string) =>
	lift(new Write({ path, content, _A: identity }))

export const remove = (path: string) => lift(new Delete({ path, _A: identity }))

// -------------------------------------------------------------------------------------
// Example
// -------------------------------------------------------------------------------------
const moveFile = (from: string, to: string) =>
	pipe(
		read(from),
		chain(content => write(to, content)),
		chain(_ => remove(from)),
	)

export interface EffectF extends P.HKT {
	readonly type: T.Effect<this["R"], this["E"], this["A"]>
}

const EffectMonad: P.Monad<EffectF> = {
	chain: T.chain,
	map: T.map,
	of: T.succeed,
}

const readFile = (path: string) =>
	T.promise(
		() =>
			new Promise<Ei.Either<unknown, string>>(resolve =>
				FS.readFile(path, { encoding: "utf-8" }, (err, data) => {
					if (!err) return resolve(Ei.right(data))
					resolve(Ei.left(err)) // Typed error would obviously be better
				}),
			),
	)

const FileSystemInterpreter = <R, E, A>(program: Free.Free<DiskF, R, E, A>): T.Effect<R, E, A> =>
	pipe(
		program,
		Free.foldMap(EffectMonad)<DiskF>(
			matchTag({
				Read: _ =>
					pipe(
						readFile(_.path),
						T.absolve, // Swallow the Either, we have Effect<unknown, never, Either<unknown, string>>, the DSL says we must return Effect<unknown, never, string>
						T.orDie, // Swallow the typed error
						T.map(_._A),
					),
				Write: _ => T.die("Pretty much the same as readfile"),
				Delete: _ => T.die("Pretty much the same as readfile"),
			}),
		),
	)

const moveHelloTS = pipe(moveFile("hello.ts", "goodby.ts"), FileSystemInterpreter, T.runPromiseExit)

Free.ts

import { Tagged } from "@effect-ts/core/Case"
import * as P from "../../prelude"
import { pipe, flow, identity } from "@effect-ts/core/Function"
import { matchTag } from "@effect-ts/core/Utils"

// -------------------------------------------------------------------------------------
// Model
// -------------------------------------------------------------------------------------
class Pure<F extends P.HKT, R, E, A> extends Tagged("Pure")<{
	_F: (f: never) => F
	_R: (r: unknown) => R
	_E: (e: never) => E
	a: A
}> {}

class Lift<F extends P.HKT, R, E, A> extends Tagged("Lift")<{
	fa: P.Kind<F, R, E, A>
}> {}

class Chain<F extends P.HKT, R, E, A> extends Tagged("Chain")<{
	use: <X>(
		go: <R1, E1, A1, R2, E2, A2>(params: {
			fa: Free<F, R1, E1, A1>
			ffb: (a: A1) => Free<F, R2, E2, A2>
			_R: (r: R) => R1 & R2
			_E: (e: E1 | E2) => E
			_A: (A: A2) => A
		}) => X,
	) => X
}> {}

export type Free<F extends P.HKT, R, E, A> =
	| Pure<F, R, E, A>
	| Lift<F, R, E, A>
	| Chain<F, R, E, A>

// -------------------------------------------------------------------------------------
// Combinators
// -------------------------------------------------------------------------------------
export const pure =
	<F extends P.HKT>() =>
	<A>(a: A): Free<F, unknown, never, A> =>
		new Pure({ _F: identity, _R: identity, _E: identity, a })

export const lift =
	<F extends P.HKT>() =>
	<R, E, A>(fa: P.Kind<F, R, E, A>): Free<F, R, E, A> =>
		new Lift({
			fa,
		})

export const chain =
	<F extends P.HKT>() =>
	<R2, E2, A, B>(ffb: (a: A) => Free<F, R2, E2, B>) =>
	<R1, E1>(fa: Free<F, R1, E1, A>): Free<F, R1 & R2, E1 | E2, B> =>
		new Chain({
			use: go =>
				go({
					ffb,
					fa,
					_R: identity,
					_E: identity,
					_A: identity,
				}),
		})

export const map =
	<F extends P.HKT>() =>
	<A, B>(f: (a: A) => B) =>
	<R, E>(fa: Free<F, R, E, A>): Free<F, R, E, B> =>
		pipe(fa, chain<F>()(flow(f, pure<F>())))

export const foldMap =
	<G extends P.HKT>(M: P.Monad<G>) =>
	<F extends P.HKT>(nt: <R, E, A>(f: P.Kind<F, R, E, A>) => P.Kind<G, R, E, A>) =>
	<R, E, A>(self: Free<F, R, E, A>): P.Kind<G, R, E, A> =>
		pipe(
			self,
			matchTag({
				Pure: _ => M.of(_.a),
				Lift: _ => nt(_.fa),
				Chain: _ =>
					_.use(({ fa, ffb, _A }) =>
						pipe(
							foldMap(M)(nt)(fa), //
							M.chain(flow(ffb, foldMap(M)(nt))),
							M.map(_A), // help typescript understand that `A2` from `Chain` class is the same as `A`
							a => a as P.Kind<G, any, any, A>, // We don't have a way to `map` the `R` or `E` type with a monad so cast it is
						),
					),
			}),
		)

export const makeFree = <F extends P.HKT>() => ({
	pure: pure<F>(),
	lift: lift<F>(),
	map: map<F>(),
	chain: chain<F>(),
})

prelude.ts

import * as EI from "@effect-ts/core/Either"
import { pipe } from "@effect-ts/core/Function"

export declare const URI: unique symbol

export interface Typeclass<F extends HKT> {
	readonly [URI]?: F
}

export interface HKT {
	readonly R?: unknown
	readonly E?: unknown
	readonly A?: unknown
	readonly type?: unknown
}

export type Kind<F extends HKT, R, E, A> = F extends { readonly type: unknown }
	? (F & {
		 
			readonly R: R
			readonly E: E
			readonly A: A
	  })["type"]
	: {
			readonly _F: F
			readonly _R: (_: R) => void
			readonly _E: () => E
			readonly _A: () => A
	  }

export interface ComposeF<F extends HKT, G extends HKT> extends HKT {
	readonly type: Kind<
		F,
		this["R"],
		this["E"],
		Kind<G, this["R"], this["E"], this["A"]>
	>
}


export interface Functor<F extends P.HKT> extends P.Typeclass<F> {
	readonly map: <A, B>(
		f: (a: A) => B,
	) => <R, E>(fa: P.Kind<F, R, E, A>) => P.Kind<F, R, E, B>
}

export interface Pointed<F extends P.HKT> extends Functor<F> {
	readonly of: <A>(a: A) => P.Kind<F, unknown, never, A>
}

export interface Apply<F extends P.HKT> extends Functor<F> {
	readonly ap: <R, E1, A>(
		fa: P.Kind<F, R, E1, A>,
	) => <R1, E, B>(
		fab: P.Kind<F, R1, E, (a: A) => B>,
	) => P.Kind<F, R & R1, E | E1, B>
}

export function getApply<F extends P.HKT>(F: Monad<F>): Apply<F> {
	return {
		map: F.map,
		ap: <R1, E1, A>(fa: P.Kind<F, R1, E1, A>) => <R2, E, B>(
			fab: P.Kind<F, R2, E, (a: A) => B>,
		) =>
			pipe(
				fa,
				F.chain(a =>
					pipe(
						fab,
						F.map(f => f(a)),
					),
				),
			),
	}
}

export interface Applicative<F extends P.HKT> extends Pointed<F>, Apply<F> {}

export function getApplicative<F extends P.HKT>(F: Monad<F>): Applicative<F> {
	return {
		...getApply(F),
		of: F.of,
	}
}

export interface Monad<F extends P.HKT> extends Pointed<F> {
	readonly chain: <A, R1, E1, B>(
		f: (a: A) => P.Kind<F, R1, E1, B>,
	) => <R, E>(fa: P.Kind<F, R, E, A>) => P.Kind<F, R & R1, E | E1, B>
}

export interface Traversable<F extends P.HKT> extends P.Typeclass<F> {
	readonly traverse: <G extends P.HKT>(
		G: Applicative<G>,
	) => <A, B, RG, EG>(
		f: (a: A) => P.Kind<G, RG, EG, B>,
	) => <RF, EF>(
		self: P.Kind<F, RF, EF, A>,
	) => P.Kind<G, RG, EG, P.Kind<F, RF, EF, B>>
}

export interface Semigroup<A> {
	readonly concat: (left: A, right: A) => A
}

export interface Eitherable<F extends P.HKT> extends P.Typeclass<F> {
	readonly either: <R, E, A>(
		fa: P.Kind<F, R, E, A>,
	) => P.Kind<F, R, never, EI.Either<E, A>>
}

export interface Failable<F extends P.HKT> extends P.Typeclass<F> {
	readonly fail: <E>(fa: E) => P.Kind<F, unknown, E, never>
}