A rough implementation of free monads in the style of Haskell's operational package

free_monads.js

'use strict';

// see: http://hackage.haskell.org/package/operational-0.2.3.2/docs/Control-Monad-Operational.html
// run in node, e.g.:
//   > let free = require('./free_monads.js')
//   undefined
//   > free.main()
//   Log: foo + bar: 52
//   test 1: [object Object]
//   k: 10, v: foo
//   k: 42, v: bar
//   k: 666, v: baz
//   k: 52, v: foo+bar
//   test 2: 30,33
//   undefined


// Basic representation of free programs
class Program {
    constructor(type) {
        this.type = type;
    }

    static inject(x) {
        return new Lift(x);
    }

    flatMap(f) {
        return new Bind(this, f);
    }
    
    map(f) {
        return new Bind(this, x => Program.inject(f(x)));
    }
    
    andThen(k) {
        return new Bind(this, _ => k);
    }

    get view() {
        switch(this.type) {
        case 'Lift':
            return new Return(this.value);
        case 'Bind':
            switch(this.m.type) {
            case 'Lift':
                return this.f(this.m).view;
            case 'Bind':
                return (new Bind(this.m.m, x => new Bind(this.m.f(x), this.f))).view;
            case 'Instr':
                return new Continue(this.m.instr, this.f);
            default:
                throw 'Error 1';
            }
        case 'Instr':
            return new Continue(this.instr, Program.inject);
        default:
            throw 'Error 2';
        }
    }
}

class Lift extends Program {
    constructor(value) {
        super('Lift');
        this.value = value;
    }
}

class Bind extends Program {
    constructor(m, f) {
        super('Bind');
        this.m = m;
        this.f = f;
    }
}

class Instr extends Program {
    constructor(instr) {
        super('Instr');
        this.instr = instr;
    }
}



// Views of programs, used to interpret them
class ProgramView {
    constructor(type) {
        this.type = type;
    }
}

class Return extends ProgramView {
    constructor(value) {
        super('Return');
        this.value = value;
    }
}

class Continue extends ProgramView {
    constructor(instr, cont) {
        super('Continue');
        this.instr = instr;
        this.cont = cont;
    }
}



// example 1
// operations: getThing: String -> P Int, putThing: (String, Int) -> P (), log: String -> P ()

function GetThing(name) {
    return new Instr({type: 'GetThing', name: name});
}

function PutThing(name, value) {
    return new Instr({type: 'PutThing', name: name, value: value});
}

function Log(msg) {
    return new Instr({type: 'Log', msg: msg});
}

function interpret1(program, database) {
    let view = program.view;
    
    switch(view.type) {
    case 'Return':
        return view.value;
    case 'Continue': 
        switch(view.instr.type) {
        case 'GetThing':
            let result = database.get(view.instr.name);
            return interpret1(view.cont(result), database);
        case 'PutThing':
            database.set(view.instr.name, view.instr.value);
            return interpret1(view.cont({}), database);
        case 'Log':
            console.log(`Log: ${view.instr.msg}`);
            return interpret1(view.cont({}), database);
        default:
            throw 'Error';
        }
    default:
        throw 'Error';    
    }
}


// example 2: stack machines, similar to example in the operational tutorial
function Push(n) {
    return new Instr({type: 'Push', value: n});
}

function Pop() {
    return new Instr({type: 'Pop'});
}

function Add() {
    return new Instr({type: 'Add'});
}

function interpret2(program, stack) {
    //console.log(`program: ${JSON.stringify(program)}`);
    //console.log(`view: ${JSON.stringify(program.view)}`);
    let view = program.view;
    //console.log('view done.');

    switch (view.type) {
    case 'Return':
        return view.value;
    case 'Continue':
        switch (view.instr.type) {
        case 'Push':
            return interpret2(view.cont({}), [view.instr.value].concat(stack));
        case 'Pop':
            return interpret2(view.cont(stack[0]), stack.slice(1));
        case 'Add':
            let result = stack[0] + stack[1];
            return interpret2(view.cont(result), [result].concat(stack.slice(2)));
        default:
            throw 'Error';
        }
    default:
        throw 'Error';
    }
}


// testing stuff
function main() {

    let testProgram1 = GetThing('foo').flatMap(
        foo => GetThing('bar').flatMap(
            bar => Log(`foo + bar: ${foo + bar}`).flatMap(
                _ => PutThing('foo+bar', foo + bar))));
    //console.log(testProgram1);

    let testEnv = new Map();
    testEnv.set('foo', 10);
    testEnv.set('bar', 42);
    testEnv.set('baz', 666);
    
    console.log(`test 1: ${interpret1(testProgram1, testEnv)}`);
    testEnv.forEach((key, value) => console.log(`k: ${key}, v: ${value}`));
//    console.log(`result 1: ${testEnv.toString()}`);


    let testProgram2 = Push(10).andThen(Push(20))
        .andThen(Add())
        .andThen(Push(33))
        .andThen(Pop()).flatMap(
            thirtyTwo => Pop().flatMap(
                sum => Program.inject([sum, thirtyTwo])));
    
    console.log(`test 2: ${interpret2(testProgram2, [])}`);
}

//main();

exports.Program = Program;
exports.Lift = Lift;
exports.Bind = Bind;
exports.Instr = Instr;
exports.GetThing = GetThing;
exports.Return = Return;
exports.Continue = Continue;

// test 1
exports.PutThing = PutThing;
exports.Log = Log;
exports.ProgramView = ProgramView;
exports.interpret1 = interpret1;

//test 2
exports.Push = Push;
exports.Pop = Pop;
exports.Add = Add;
exports.interpret2 = interpret2;

exports.main = main;

// module.exports = {
//     Lift: Lift,
//     Instr: Instr,
//     Bind: Bind
// }