Value Polymorphism with Clojure Style Overloaded Functions

value-polymorphism.js

// type constructor


const toTypeTag = x => {
  const tag = Object.prototype.toString.call(x);
  return tag.slice(tag.lastIndexOf(" ") + 1, -1);
};


const TAG = Symbol("TAG");


const Type = name => {
  const Type = tag => Dcons => {
    const t = new Tcons();

    Object.defineProperty(
      t,
      `run${name}`,
      {value: Dcons});

    t[TAG] = tag;
    return t;
  };

  const Tcons =
    Function(`return function ${name}() {}`) ();

  Tcons.prototype[Symbol.toStringTag] = name;
  return Type;
};


// custom type


const Option = Type("Option");


const None = Option("None") (cases => cases.None);
const Some = x => Option("Some") (cases => cases.Some(x));


// overloaded functions


const overload = (name, dispatch) => {
  const pairs = new Map();

  return {
    [`${name}Add`]: (k, v) => pairs.set(k, v),

    [`${name}Lookup`]: k => pairs.get(k),

    [name]: x => {
      const r = pairs.get(dispatch(x));

      if (r === undefined)
        throw new OverloadError(
          "invalid overloaded function call"
          + `\n\n${name} cannot dispatch on ${dispatch(x)}`
          + "\n\non the 1st call"
          + "\nin the 1st argument"
          + `\n\nfor the given value of type ${toTypeTag(x)}`
          + "\n");

      else if (typeof r === "function")
        return r(x);

      else return r;
    }
  }
};


const overload2 = (name, dispatch) => {
  const pairs = new Map();

  return {
    [`${name}Add`]: (k, v) => pairs.set(k, v),

    [`${name}Lookup`]: k => pairs.get(k),

    [name]: x => y => {
      if (typeof x === "function" && (VALUE in x))
        x = x(y);

      else if (typeof y === "function" && (VALUE in y))
        y = y(x);

      const r = pairs.get(dispatch(x, y));

      if (r === undefined)
        throw new OverloadError(
          "invalid overloaded function call"
          + `\n\n${name} cannot dispatch on ${dispatch(x)}/${dispatch(y)}`
          + "\n\non the 1st/2nd call"
          + "\nin the 1st argument"
          + `\n\nfor the given values of type ${toTypeTag(x)}/${toTypeTag(y)}`
          + "\n");

      else if (typeof r === "function")
        return r(x) (y);

      else return r;
    }
  }
};


class OverloadError extends Error {
  constructor(s) {
    super(s);
    Error.captureStackTrace(this, OverloadError);
  }
}


const dispatcher = (...args) => args.map(arg => {
  const tag = Object.prototype.toString.call(arg);
  return tag.slice(tag.lastIndexOf(" ") + 1, -1);
}).join("/");


const VALUE = Symbol("VALUE");


// typeclasses


const {appendAdd, appendLookup, append} =
  overload2("append", dispatcher);


const {emptyAdd, emptyLookup, empty} =
  overload("empty", toTypeTag);

empty[VALUE] = "empty";


// typeclass instances


emptyAdd("Option", None);
emptyAdd("String", "");


appendAdd("Option/Option", tx => ty => tx.runOption({
  None: ty,
  Some: x => ty.runOption({
    None: tx,
    Some: y => Some(append(x) (y))})}));


appendAdd("String/String", s => t => `${s}${t}`);


const id = x => x;


// SIMULATE VALUE POLYMORPHISM


// with primitives


console.log(
  "append(String) (String)", append("foo") ("bar")
); // "foobar"


console.log(
  "append(String) (empty)", append("foo") (empty)
); // "foo"


console.log(
  "append(empty) (String)", append(empty) ("bar")
); // "bar"


// with composite types


console.log(
  "append(Some) (Some)", append(Some("foo")) (Some("bar")).runOption({Some: id, None: id})
); // "foobar"


console.log(
  "append(Some) (empty)", append(Some("foo")) (empty).runOption({Some: id, None: id})
); // "foo"


console.log(
  "append(empty) (Some)", append(empty) (Some("bar")).runOption({Some: id, None: id})
); // "bar"