feat: Add type class implementations for State (#242)

src/free.test.ts

@@ -1,41 +1,45 @@
 import { assertEquals } from "../deps.ts";
-import { catT, doVoidT } from "./cat.ts";
+import { catT, doT, doVoidT } from "./cat.ts";
 import {
     eq,
+    foldFree,
     type Free,
     liftF,
+    monad,
     monad as freeMonad,
     pure,
     runFree,
     wrap,
 } from "./free.ts";
-import type { Hkt1 } from "./hkt.ts";
+import type { Apply2Only, Hkt1 } from "./hkt.ts";
+import { monadRec, runState, type State, type StateHkt } from "./state.ts";
 import { type Eq, fromEquality } from "./type-class/eq.ts";
 import type { Functor } from "./type-class/functor.ts";
-
-type Hello<T> = {
-    type: "Hello";
-    next: T;
-};
-type Hey<T> = {
-    type: "Hey";
-    next: T;
-};
-type YearsOld<T> = {
-    type: "YearsOld";
-    years: number;
-    next: T;
-};
-type Bye = {
-    type: "Bye";
-};
-type HelloLang<T> = Hello<T> | Hey<T> | YearsOld<T> | Bye;
-
-interface HelloLangHkt extends Hkt1 {
-    readonly type: HelloLang<this["arg1"]>;
-}
+import type { Nt } from "./type-class/nt.ts";
 
 Deno.test("hello language", async (t) => {
+    type Hello<T> = {
+        type: "Hello";
+        next: T;
+    };
+    type Hey<T> = {
+        type: "Hey";
+        next: T;
+    };
+    type YearsOld<T> = {
+        type: "YearsOld";
+        years: number;
+        next: T;
+    };
+    type Bye = {
+        type: "Bye";
+    };
+    type HelloLang<T> = Hello<T> | Hey<T> | YearsOld<T> | Bye;
+
+    interface HelloLangHkt extends Hkt1 {
+        readonly type: HelloLang<this["arg1"]>;
+    }
+
     const map =
         <T1, U1>(fn: (t: T1) => U1) => (code: HelloLang<T1>): HelloLang<U1> => {
             switch (code.type) {
@@ -133,3 +137,44 @@ Deno.test("hello language", async (t) => {
         );
     });
 });
+
+Deno.test("teletype language", () => {
+    type TeletypeF<T> = {
+        type: "PUT_STR_LN";
+        line: string;
+        next: T;
+    } | {
+        type: "GET_LINE";
+        callback: (line: string) => T;
+    };
+    interface TeletypeHkt extends Hkt1 {
+        readonly type: TeletypeF<this["arg1"]>;
+    }
+    type Teletype<T> = Free<TeletypeHkt, T>;
+
+    const putStrLn = (line: string): Teletype<never[]> =>
+        liftF({ type: "PUT_STR_LN", line, next: [] });
+    const getLine: Teletype<string> = liftF({
+        type: "GET_LINE",
+        callback: (line) => line,
+    });
+
+    const teletypeMock: Nt<TeletypeHkt, Apply2Only<StateHkt, string>> = {
+        nt: <T>(f: TeletypeF<T>): State<string, T> =>
+        (state: string): [T, string] =>
+            f.type === "PUT_STR_LN"
+                ? [f.next, state + "\n" + f.line]
+                : [f.callback("fake input"), state],
+    };
+
+    const run = foldFree(monadRec<string>())(teletypeMock);
+
+    const echo: Teletype<string> = doT(monad<TeletypeHkt>())
+        .addM("line", getLine)
+        .runWith(({ line }) => putStrLn(line))
+        .run(putStrLn("Finished"))
+        .finishM(({ line }) => pure<TeletypeHkt, string>(line + ", " + line));
+
+    const actual = runState(run.nt(echo))("");
+    assertEquals(actual, ["fake input, fake input", "\nfake input\nFinished"]);
+});

src/free.ts

@@ -587,12 +587,7 @@ export const applicative = <F>(): Applicative<Apply2Only<FreeHkt, F>> => ({
 /**
  * The instance of `Functor` for `Free<F, _>` from a functor `F`.
  */
-export const functor = <F>(): Monad<Apply2Only<FreeHkt, F>> => ({
-    map,
-    pure,
-    apply,
-    flatMap,
-});
+export const functor = <F>(): Functor<Apply2Only<FreeHkt, F>> => ({ map });
 
 /**
  * The instance of `Monad` for `Free<F, _>` from a functor `F`.

src/state.ts

@@ -6,6 +6,9 @@ import type { Monad } from "./type-class/monad.ts";
 import type { Pure } from "./type-class/pure.ts";
 import type { FlatMap } from "./type-class/flat-map.ts";
 import { doT } from "./cat.ts";
+import type { MonadRec } from "./type-class/monad-rec.ts";
+import { type ControlFlow, isContinue, newContinue } from "./control-flow.ts";
+import type { Applicative } from "./type-class/applicative.ts";
 
 /**
  * The state monad transformer, the computation allows you to carry and modify the state `S` of it and returns the result `A` on `M`.
@@ -297,6 +300,18 @@ export const flatMap =
 export const flatten = <S, A>(ss: State<S, State<S, A>>): State<S, A> =>
     flatMap((s: State<S, A>) => s)(ss);
 
+export const tailRecM = <S, X, A>(
+    stepper: (ctx: A) => State<S, ControlFlow<X, A>>,
+) =>
+(ctx: A): State<S, X> =>
+(state: S): [X, S] => {
+    let flow: ControlFlow<X, A> = newContinue(ctx);
+    while (isContinue(flow)) {
+        [flow, state] = stepper(flow[1])(state);
+    }
+    return [flow[1], state];
+};
+
 export interface StateTHkt extends Hkt3 {
     readonly type: StateT<this["arg3"], this["arg2"], this["arg1"]>;
 }
@@ -309,6 +324,16 @@ export interface StateHkt extends Hkt2 {
  * The instance of `Functor` for `State<S, _>`.
  */
 export const functor = <S>(): Functor<Apply2Only<StateHkt, S>> => ({ map });
+
+/**
+ * The `Applicative` instance for `State<S, _>`.
+ */
+export const applicative = <S>(): Applicative<Apply2Only<StateHkt, S>> => ({
+    map,
+    apply,
+    pure,
+});
+
 /**
  * The instance of `Monad` for `State<S, _>`.
  */
@@ -319,6 +344,14 @@ export const monad = <S>(): Monad<Apply2Only<StateHkt, S>> => ({
     flatMap,
 });
 
+export const monadRec = <S>(): MonadRec<Apply2Only<StateHkt, S>> => ({
+    map,
+    apply,
+    pure,
+    flatMap,
+    tailRecM,
+});
+
 /**
  * The instance of `Functor` for `StateT<S, M, _>`.
  */