Free monad implementation in JS

free.js

// Largely translated from https://github.com/purescript/purescript-free

var Fn = require('../fn/fn')
var Type = require('../type/type');
var Identity = require('../data/identity');
var Either = require('../data/either');
var List = require('../catenable/list');


var Free = Type.product('view', 'list');

var FreeView = Type.sum({
  Return: ['a'],
  Bind: ['a', 'f']
});

var fromView = function(v) {
  return Free(v, List.empty);
};

/* // for plain arrays rather than catenable lists
var fromView = function(v) {
  return Free(v, []);
};
*/

var concatF = function(free, r) {
  return free.unapply(function(v, list) {
    return Free(v, List.append(list, r));
    //// for plain arrays rather than catenable lists
    //return Free(v, list.concat(r));
  });
};

var toView = Type.unapply(function(v, list) {
  return v.match({
    Bind: function (f, k) {
      return FreeView.Bind(f, function (a) {
        return concatF(k(a), list);
      })
    },
    Return: function (a) {

      return List.uncons(list).match({
        Nothing: function() {
          return FreeView.Return(a);
        },
        Just: Type.unapply(function(head, tail) {
          return toView(concatF(head(a), tail));
        })
      });

      //// for plain arrays rather than catenable lists
      //return list.length > 0 ? toView(concatF(list[0](a), list.slice(1)))
      //                       : FreeView.Return(a);
    }
  })
});

Free.map = Fn(function(k, f) {
  return Free.chain(Fn.compose(Free.of, k), f);
});

Free.prototype.map = function(k) {
  return Free.map(k, this);
};

Free.chain = Fn(function(k, f) {
  return f.unapply(function(view, list) {
    return Free(view, List.snoc(list, k));
    //// for plain arrays rather than catenable lists
    //return Free(view, list.concat(k));
  });
});

Free.prototype.chain = function(k) {
  return Free.chain(k, this);
};

Free.prototype.of = Free.of = Fn.compose(fromView, FreeView.Return);

Free.ap = Fn(function(ff, fa) {
  return Free.chain(function(f) {
    return Free.map(f, fa);
  });
});

Free.prototype.ap = function(fa) {
  return Free.ap(this, fa);
};

Free.tailRecM = Fn(function(k, a) {
  return Free.chain(function(e) {
    return e.match({
      Left: Free.tailRecM(k),
      Right: Free.of
    })
  }, k(a));
});

Free.liftF = function(f) {
  return fromView(FreeView.Bind(f, Free.of));
};

Free.suspendF = function(F, f) {
  return fromView(FreeView.Bind(F.of(f), Identity.I));
};

Free.map = function(k) {
  return Free.fold(Fn.compose(Free.liftF, k));
};

Free.fold = Fn(function(M, k) {
  return M.tailRecM(function(f) {
    return toView(f).match({
      Return: function(a) {
        return M.of(a).map(Either.Right);
      },
      Bind: function(g, i) {
        return k(g).map(Fn.compose(Either.Left, i));
      }
    });
  });
});

Free.run = function(k) {
  return Fn.compose(
    function(i) { return i.value; },
    Free.runM(Identity, Fn.compose(Identity, k))
  );
};

Free.runM = Fn(function(M, k) {
  return M.tailRecM(function(f) {
    return toView(f).match({
      Return: function(a) {
        return M.of(a).map(Either.Right);
      },
      Bind: function(g, i) {
        return k(g.map(i)).map(Either.Left);
      }
    })
  })
});

module.exports = Free;

teletype.js

// EXAMPLE USAGE

var Fn = require('../../src/fn/fn');
var Type = require('../../src/type/type');
var Identity = require('../../src/data/identity');
var IO = require('../../src/data/io');
var Free = require('../../src/free/free');
var Monad = require('../../src/control/monad');
var Unit = Type.product();


// Declare the valid commands for the simple teletype program
var TeletypeF = Type.sum({ PutStrLn: ['str', 'a'], GetLine: ['f'] });

// Simple logging function for demonstration
var log = s => IO(() => console.log(s));

// Helpers for lifting TeletypeF into Free
var putStrLn = s => Free.liftF(TeletypeF.PutStrLn(s, Unit));
var getLine = Free.liftF(TeletypeF.GetLine(Identity.I));

// Interpreter mapping (natural transformation) from TeletypeF to IO
var teletypeN = Type.match({
  PutStrLn: (s, a) => IO.map(Fn.of(a), log(s)),
  GetLine: k => IO.of(k("fake input"))
});

// Create the Free TeletypeN interpreter
var run = Free.fold(IO, teletypeN);

// A simple program (not bound to any implementation yet)
var echo = Monad.genDo(function*() {
  var a = yield getLine;
  yield putStrLn(a);
  yield putStrLn("Finished");
  return Free.of(a + " " + a);
});

// Use the IO interpreter to run the program
IO.runIO(run(echo).chain(log));

// Test for stack safety
var counter = Monad.genDo(function*() {
  var i = 1000000;
  while (i--) yield putStrLn(i);
  return putStrLn('DONE');
});

IO.runIO(run(counter));