Navigation Menu

Skip to content

Commit

Permalink
added optimization hook for monads
Browse files Browse the repository at this point in the history
  • Loading branch information
@sledorze
sledorze committed Dec 30, 2011
1 parent 5e7b1b0 commit 56dd18c
Showing 1 changed file with 70 additions and 90 deletions.
160 changes: 70 additions & 90 deletions src/com/mindrocks/macros/MonadSugarMacro.hx
View file
Expand Up @@ -11,7 +11,7 @@ import com.mindrocks.macros.Staged;
using PreludeExtensions;
// using haxe.data.collections.ArrayExtensions;

// Introduire des rewrite rules (d'abord abstraire les transfos (mini AST pour separer la detection de la transformation)
// Introduire des rewrite rules

import com.mindrocks.functional.Functional;

Expand All @@ -20,28 +20,69 @@ import com.mindrocks.functional.Functional;
* @author sledorze
*/
class OptionM {

static function optimize(m : MonadOp, position : Position) : MonadOp {
function mk(e : ExprDef) return { pos : position, expr : e };
switch(m) {
case MFlatMap(e, bindName, body):
var body = optimize(body, position);
var e = optimize(e, position);

switch (e) {
case MCall(name, params):
switch (name) {
case "ret": return optimize(MFuncApp(bindName, body, MExp(params[0])), position);
default :
}
default:
switch (body) {
case MCall(name, params):
switch (name) {
case "ret": return optimize(MMap(e, bindName, MExp(params[0])), position);
default :
}
default:
}
}

return MFlatMap(e, bindName, body);

default:
return m;
}
}

@:macro public static function Do(body : Expr) return
Monad.Do("OptionM", body, Context)
Monad.Do("OptionM", body, Context, optimize)

inline public static function ret<T>(x : T) return
Some(x)

inline public static function flatMap<T>(x : Option<T>, f : T -> Option<T>) : Option<T> {
inline public static function map < T, U > (x : Option<T>, f : T -> U) : Option<U> {
switch (x) {
case Some(x) : return f(x);
case Some(x) : return Some(f(x));
default : return None;
}
}

inline public static function flatMap<T, U>(x : Option<T>, f : T -> Option<U>) : Option<U> {
switch (x) {
case Some(x) :
var xx = f(x);
return xx;
default : return None;
}
}
}

class ArrayM {
@:macro public static function Do(body : Expr) return
Monad.Do("ArrayM", body, Context)
Monad.Do("ArrayM", body, Context, function (x, _) return x)

inline public static function ret<T>(x : T) return
[x]

inline public static function flatMap<T>(xs : Array<T>, f : T -> Array<T>) : Array<T> {
inline public static function flatMap<T, U>(xs : Array<T>, f : T -> Array<U>) : Array<U> {
var res = [];
for (x in xs) {
for (y in f(x)) {
Expand All @@ -54,13 +95,15 @@ class ArrayM {

enum MonadOp {
MExp(e : Expr);
MBind(e : MonadOp, bindName : String, body : MonadOp);
MFuncApp(paramName : String, body : MonadOp, app : MonadOp);
MFlatMap(e : MonadOp, bindName : String, body : MonadOp);
MMap(e : MonadOp, bindName : String, body : MonadOp);
MCall(name : String, params : Array<Expr>);
}

class Monad {

public static function Do(monadTypeName : String, body : Expr, context : Dynamic) {
public static function Do(monadTypeName : String, body : Expr, context : Dynamic, optimize : MonadOp -> Position -> MonadOp) {
var position : Position = context.currentPos();
function mk(e : ExprDef) return { pos : position, expr : e };

Expand Down Expand Up @@ -104,7 +147,7 @@ class Monad {
var e = promoteExpression(rightExpr);
switch (nexts) {
case Some(next):
return Some(MBind(e, name, next));
return Some(MFlatMap(e, name, next));
case None :
return Some(e);
}
Expand All @@ -121,100 +164,37 @@ class Monad {
function materialise(m : MonadOp) : Expr {
switch (m) {
case MExp(e) : return e;
case MBind(e, bindName, body) :
var exprs = materialise(body);
var rest : Expr = mk(EReturn(exprs));

case MFlatMap(e, bindName, body) :
var rest = mk(EReturn(materialise(body)));
var func = mk(EFunction(null, { args : [ { name : bindName, type : null, opt : false, value : null } ], ret : null, expr : rest, params : [] } ));
var res = mk(ECall(mk(EField(mk(EConst(CType(monadTypeName))), "flatMap")), [materialise(e), func]));
return res;
case MCall(name, params) :
var res = mk(ECall(mk(EField(mk(EConst(CType(monadTypeName))), name)), params));

case MMap(e, bindName, body) :
var rest = mk(EReturn(materialise(body)));
var func = mk(EFunction(null, { args : [ { name : bindName, type : null, opt : false, value : null } ], ret : null, expr : rest, params : [] } ));
var res = mk(ECall(mk(EField(mk(EConst(CType(monadTypeName))), "map")), [materialise(e), func]));
return res;

case MCall(name, params) :
return mk(ECall(mk(EField(mk(EConst(CType(monadTypeName))), name)), params));

case MFuncApp(paramName, body, app):
var bdy = mk(EReturn(materialise(body)));
var func = mk(EFunction(null, { args : [ { name : paramName, type : null, opt : false, value : null } ], ret : null, expr : bdy, params : [] } ));
return mk(ECall(func, [materialise(app)]));
}
}

switch (body.expr) {
case EBlock(exprs):
switch(exprs.foldr(None, transform)) {
case Some(monad): return materialise(monad);
case Some(monad): return materialise(optimize(monad, position));
case None: return mk(EBlock([]));
}

default : return body;
};
}

}

/*
class Monad {
public static function Do<Q>(monadTypeName : String, body : Expr, context : Dynamic) {
var position : Position = context.currentPos();
function mk(e : ExprDef) return { pos : position, expr : e };
function promoteExpression(e : Expr) : Expr {
switch (e.expr) {
case ECall(exp, params) :
switch (exp.expr) {
case EConst(const):
switch (const) {
case CIdent(name):
try {
context.typeof(exp);
} catch (e : Dynamic) { // change this to a call from the Monad object.
return mk(ECall(mk(EField(mk(EConst(CType(monadTypeName))), name)), params));
}
default:
}
default:
}
default:
}
return e;
}
function transform(e : Expr, nexts : Array<Expr>) : Array<Expr> {
switch (e.expr) {
case EBinop(op, l, rightExpr) :
switch (op) {
case OpLte:
var name : String =
switch (l.expr) {
case EConst(c) :
switch (c) {
case CIdent(name) : name;
default : null;
}
default : null;
}
if (name != null) {
var rest : Expr = mk(EReturn(mk(EBlock(nexts))));
var func = mk(EFunction(null, { args : [ { name : name, type : null, opt : false, value : null } ], ret : null, expr : rest, params : [] } ));
var res = mk(ECall(mk(EField(mk(EConst(CType(monadTypeName))), "flatMap")), [promoteExpression(rightExpr), func]));
// var res = mk(ECall(mk(EField(promoteExpression(rightExpr), "flatMap")), [func]));
return [res];
}
default :
}
default:
}
nexts.insert(0, promoteExpression(e));
return nexts;
}
switch (body.expr) {
case EBlock(exprs): return mk(EBlock(exprs.foldr([], transform)));
default : return body;
};
}
}
}
* */

0 comments on commit 56dd18c

Please sign in to comment.