The CPS-ed freer monad

cpsfreer.js

const { adt, match, otherwise } = require("@masaeedu/adt");
const {
  Obj,
  Fn,
  Arr,
  Cont,
  implement,
  Functor,
  Apply,
  Chain,
  fail
} = require("@masaeedu/fp");
const { mdo } = require("@masaeedu/do");

// ##### FREER

// The (CPS-ed) freer monad; a model for mixed effects

// A freer computation is simply a function that accepts some effectful
// callback, and utilizes it to to cause an overall effect.

// The callback consumes "pure results" of type `a` and "effect requests"
// of type `(f x, x -> m r)` (for some `x`), and given either sort of input
// produces some effect `m r`.

// We can think of this callback as translating both final results and int-
// ermediate effect requests (which contain *another* callback to be used
// for continuing) into some useful effect (perhaps console output, or HTTP
// requests, or user visible activity on a web page).

// We'll use an ADT to model the inputs to an effect callback.

// :: type FreerInput f a r = ADT '{ Pure: '[a], Bind: '[f x, x -> r] }

const FreerInput = adt({ Pure: ["a"], Bind: ["f x", "x -> r"] });
const { Pure, Bind } = FreerInput;

// A freer computation, when given such a "effect translator" callback, simply
// calls it a bunch of times with various effect requests and results, and se-
// quences the emitted effects together.

// :: type Freer f m a = (FreerInput f a (m r) -> m r) -> m r

// Interestingly, freer forms a monad regardless of what properties `f` and `m`
// have.

// :: Monad (Freer f m)
const Freer = (() => {
  // We're just going to implement the monad's pure and bind operations and derive
  // everything else
  const monad = Fn.pipe(Arr.map(implement)([Chain, Apply, Functor, Apply]));

  // Given some value `a`, you can always produce a harmless freer computation,
  // which will accept the callback and immediately feed it `a` as a result, and
  // then turn around and hand you back the effect the callback produced.

  // :: a -> Freer f m a
  const of = a => Cont.of(Pure(a));

  // We also need a way to take an `amb :: a -> Freer f m b` and sequence it onto
  // some `ma :: Freer f m a` to produce a `result :: Freer f m b`.

  // When producing `result`, we need to remember that we're actually accepting some
  // callback `cb :: FreerInput f b (m r) -> m r` and need to use it in some manner
  // to produce a final `m r` effect. How do we do this?

  // Well what we can do is take our *previous* computation `ma`, and pass it a
  // callback that does the following:

  //   - When the computation passes us a result `a`, we take our `amb` function,
  //     apply `a` to it to obtain a `Freer f m b` computation, feed it `cb`, and
  //     boom! we have an `m r` we can return.

  //   - When the computation passes us an effect processing request, we just use
  //     `cb` to interpret it! Don't we need to do some translation between our
  //     `cb :: FreerInput f b (m r) -> m r` and the effect processing request,
  //     which after all is of type `FreerInput f a (m r)`?

  //     The beauty part here is that the `Bind` case of a `FreerInput f x (m r)`
  //     works just as well as the `Bind` case of a `FreerInput f y (m r)`; it
  //     simply doesn't mention or care about the second type parameter.

  //     This makes sense, because we're just pushing all the business of actually
  //     interpreting effect requests into proper effects straight to whomever fi-
  //     nally supplies us with a callback; we don't care what `m` or `r` they end
  //     up interpreting everything into.

  // :: (a -> Freer f m b) -> Freer f m a -> Freer f m b
  const chain = amb =>
    Cont.chain(
      match({
        Pure: amb,
        [otherwise]: Cont.of
      })
    );

  // :: f (Freer f m a) -> Freer f m a
  const wrap = fr => cb => cb(Bind(fr)(ft => ft(cb)));

  // :: Functor f -> f a -> Freer f m a
  const liftF = F => fa => wrap(F.map(of)(fa));

  // :: Functor f -> Monad m -> (f (m a) -> m a) -> Freer f m a -> m a
  const iterT = F => M => phi => m =>
    m(
      match({
        // :: a -> m a
        Pure: M.of,
        // :: f x -> (x -> m r) -> m a
        Bind: f => xmr => phi(F.map(xmr)(f))
      })
    );

  return { ...monad({ of, chain }), wrap, liftF, iterT };
})();

// ##### EFFECT REQUESTS

// # STATE

// :: type State s r = ADT '{ Get: '[s -> r], Put: '[s, r] }

const State = adt({ Get: ["s -> r"], Put: ["s", "r"] });
const { Get, Put } = State;

// :: Functor (State s)
State.map = f =>
  match({
    Get: t => Get(s => f(t(s))),
    Put: s => a => Put(s)(f(a))
  });

// :: Freer (State s) m s
const get = Freer.liftF(State)(Get(Fn.id));
// :: s -> Freer (State s) m ()
const put = s => Freer.liftF(State)(Put(s)(undefined));

// # ERROR

// :: type Error e a = ADT '{ Fail: '[e] }

const Error = adt({ Fail: ["e"] });
const { Fail } = Error;

// :: Functor (Error e)
Error.map = _ => x => x;

// :: e -> Freer (Error e) m ()
const error = e => Freer.liftF(Error)(Fail(e));

// ##### FUNCTOR UNION

// :: (Functor <$> (fs :: [* -> *])) -> Functor (Union fs)
const Union = Fs => {
  const index = Arr.foldMap(Obj)(F => Obj["<$"](F)(F.def))(Fs);
  const map = f => v => index[v.label].map(f)(v);
  return { map };
};

// ##### TESTING

// # COMPUTATION

// We're going to ask the user their name, and provided they don't have
// some weird name, we're going to greet them

const weirdnames = ["Wurtzelpfoof"]; // Apologies to all the Wurtzelpfoofs out there

// :: Freer (Union [State String, Error String]) m ()
const computation = mdo(Freer)(({ name }) => [
  () => put("Hi! I'm Telly the teletype! Who are you?"),
  [name, () => get],
  () =>
    weirdnames.includes(name)
      ? error(`${name}? What kind of name is that?`)
      : Freer.of(undefined),
  () => put(`Hello, ${name}. Nice to meet you.`)
]);

// # INTERPRETATION UTILS

// :: String -> Cont! ()
const log = msg => cb => {
  console.log(msg);
  cb(undefined);
};

// :: String -> Cont! a
const panic = str => _ => fail(str);

// # INTERPRETATION

// :: Functor (Union '[State s, Error e])
const F = Union([State, Error]);

// :: Freer (Union '[State String, Error String]) Cont! :~> Cont!
const main = Freer.iterT(F)(Cont)(
  match({
    // :: (String -> Cont! r) -> Cont! r
    Get: f => f("Sally"),
    // also try f => f("Wurtzelpfoof")

    // :: String -> Cont! r -> Cont! r
    Put: s => m => Cont["*>"](log(s))(m),

    // :: String -> Cont! r
    Fail: panic
  })
);

main(computation)(_ => {});