Skip to content
Browse files

added optimization hook for monads

  • Loading branch information...
1 parent 5e7b1b0 commit 56dd18c627ece1a9cac50506a3e0d7ec613ce874 @sledorze committed Dec 30, 2011
Showing with 70 additions and 90 deletions.
  1. +70 −90 src/com/mindrocks/macros/MonadSugarMacro.hx
View
160 src/com/mindrocks/macros/MonadSugarMacro.hx
@@ -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;
@@ -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)) {
@@ -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 };
@@ -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);
}
@@ -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.
Something went wrong with that request. Please try again.