Monads in C++ / Template Haskell [Metaprogramming]

gistfile1.hs

$ ghci -XTemplateHaskell

Prelude> :m +Language.Haskell.TH

Prelude Language.Haskell.TH> runQ [| let x = 5 in x * x |]

LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 5))) []] (InfixE (Just (VarE x_0)) (VarE GHC.Num.*) (Just (VarE x_0)))

Prelude Language.Haskell.TH> $(runQ [| let x = 5 in x * x |])
25

monads.cpp

$ g++-mp-4.5 -Wall -pedantic -std=c++0x -g -ggdb -I/opt/local/include -L/opt/local/lib -static-libstdc++ monads.cpp -o monads

#include <iostream>
#include <functional>

template<int n> struct Const {};
template<class E1, class E2> struct Plus {};
template<class E1, class E2> struct Times {};
struct Arg1 {};
struct Arg2 {};

// type Args = [Integer]
struct Args
{
    Args(int i, int j) {
        _a[0] = i;
        _a[1] = j;
    }
    int operator[](int n) { return _a[n]; }
    int _a[2];
};
/* in Haskell:
	getArg :: Int -> Prog Int
	getArg n = PR (λ args -> args !! n)
*/
template<int n> struct GetArg { // instance of the concept PR
    int operator()(Args args) {
        return args[n];
    }
};

/* Haskell's implementation of monadic bind
	bind (PR prog) cont =
	    PR (λ args ->
	        let v = prog args
	            (PR prog') = cont v
	        in
	            prog' args)
*/
template<class P1, class P2>	// compile-time type parameters
struct Bind
{
	Bind(P1 prog, std::function<P2(int)> cont)
		: _prog(prog), _cont(cont) {}

	int operator()(Args args) {
        int v = _prog(args);
        P2 prog2 = _cont(v);
        return prog2(args);
    }

	P1 _prog;
	// store a lambda continuation
    std::function<P2(int)> _cont;
};

/* in Haskell:
	return :: a -> Prog a
	return v = PR (λ args -> v)
*/
struct Return
{
    Return(int v) : _v(v) {}
    int operator()(Args args)
    {
        return _v;
    }
    int _v;
};

// compile :: Exp -> Prog Int
template<class Exp>
struct Compile;

// compile (Const c) = return c
template<int c>
struct Compile<Const<c> > : Return
{
    Compile() : Return(c) {}
};

// compile Arg1 = getArg 0
template<>
struct Compile<Arg1> : GetArg<0> {};

// compile Arg2 = getArg 1
template<>
struct Compile<Arg2> : GetArg<1> {};

/* in Haskell:
	compile (Plus exL exR) =
	  bind compile exL
	       λ left ->
	          bind compile exR
	               λ right ->
	                   return (left + right)
*/
template<class L, class R>
struct Compile<Plus<L, R> > {
  int operator()(Args args)
  {
    return Bind<Compile<L>, Bind<Compile<R>, Return> > (
      Compile<L>(),
      [](int left) -> Bind<Compile<R>, Return> {
        return Bind<Compile<R>, Return>(
          Compile<R>(),
          [left](int right) -> Return {
            return Return(left + right);
          }
        );
      }
    )(args);
  }
};

template<class L, class R>
struct Compile<Times<L, R> > {
  int operator()(Args args)
  {
    return Bind<Compile<L>, Bind<Compile<R>, Return> > (
      Compile<L>(),
      [](int left) -> Bind<Compile<R>, Return> {
        return Bind<Compile<R>, Return>(
          Compile<R>(),
          [left](int right) -> Return {
            return Return(left * right);
          }
        );
      }
    )(args);
  }
};

int main(void) {
    Args args(3, 4);
    Compile<Plus<Times<Arg1, Arg2>, Const<13> > > act;
    int v = act(args);
    std::cout << v << std::endl;
	return 0;
}