+package org.simantics.scl.compiler.top;
+
+import java.util.ArrayList;
+
+import org.simantics.scl.compiler.common.names.Name;
+import org.simantics.scl.compiler.elaboration.expressions.EApply;
+import org.simantics.scl.compiler.elaboration.expressions.EConstant;
+import org.simantics.scl.compiler.elaboration.expressions.EEnforce;
+import org.simantics.scl.compiler.elaboration.expressions.EFieldAccess;
+import org.simantics.scl.compiler.elaboration.expressions.ELambda;
+import org.simantics.scl.compiler.elaboration.expressions.ERuleset;
+import org.simantics.scl.compiler.elaboration.expressions.ESelect;
+import org.simantics.scl.compiler.elaboration.expressions.ESimpleLambda;
+import org.simantics.scl.compiler.elaboration.expressions.EWhen;
+import org.simantics.scl.compiler.elaboration.expressions.Expression;
+import org.simantics.scl.compiler.elaboration.expressions.Variable;
+import org.simantics.scl.compiler.elaboration.modules.SCLValue;
+import org.simantics.scl.compiler.environment.Environment;
+import org.simantics.scl.compiler.errors.ErrorLog;
+import org.simantics.scl.compiler.errors.Locations;
+import org.simantics.scl.compiler.internal.elaboration.utils.ExpressionDecorator;
+import org.simantics.scl.compiler.types.TCon;
+import org.simantics.scl.compiler.types.Type;
+import org.simantics.scl.compiler.types.Types;
+
+public class ToplevelEffectDecorator implements ExpressionDecorator {
+
+ ErrorLog errorLog;
+ Environment environment;
+
+ public ToplevelEffectDecorator(ErrorLog errorLog, Environment environment) {
+ this.errorLog = errorLog;
+ this.environment = environment;
+ }
+
+ private static Expression decorate(SCLValue transactionFunction, Type effect, Expression expression) {
+ Variable var = new Variable("_");
+ var.setType(Types.UNIT);
+ Expression trans = new EApply(expression.getLocation(), Types.PROC,
+ new EConstant(transactionFunction,
+ expression.getType()),
+ new ESimpleLambda(Locations.NO_LOCATION, var, effect, expression)
+ );
+ if(expression instanceof EApply) {
+ EApply apply = (EApply)expression;
+ trans = apply.toANormalForm(trans);
+ }
+ return trans;
+ }
+
+ private static final TCon R = Types.con("R/R", "R");
+
+ @Override
+ public Expression decorate(Expression expression) {
+ if(expression instanceof EApply)
+ return decorateByEffect(expression, ((EApply)expression).getLocalEffect());
+ else if(expression instanceof ESelect
+ || expression instanceof EEnforce
+ || expression instanceof EWhen
+ || expression instanceof EFieldAccess
+ || expression instanceof ERuleset)
+ return decorateByEffect(expression, expression.getEffect());
+ return expression;
+ }
+
+ private Expression decorateByEffect(Expression expression, Type effect) {
+ if(effect == Types.NO_EFFECTS)
+ return expression;
+
+ //System.out.println("decorateByEffect(" + expression + ", " + effect + ")");
+
+ ArrayList<TCon> concreteEffects = new ArrayList<TCon>();
+ effect.collectConcreteEffects(concreteEffects);
+ if(concreteEffects.contains(Types.WRITE_GRAPH)) {
+ Name name = Name.create("Simantics/DB", "syncWrite");
+ SCLValue transactionFunction = environment.getValue(name);
+ if(transactionFunction == null) {
+ errorLog.log(expression.location, "Cannot locate " + name);
+ return expression;
+ }
+
+ expression = decorate(transactionFunction, Types.WRITE_GRAPH, expression);
+ }
+ else if(concreteEffects.contains(Types.READ_GRAPH)) {
+ Name name = Name.create("Simantics/DB", "syncRead");
+ SCLValue transactionFunction = environment.getValue(name);
+ if(transactionFunction == null) {
+ errorLog.log(expression.location, "Cannot locate " + name);
+ return expression;
+ }
+
+ expression = decorate(transactionFunction, Types.READ_GRAPH, expression);
+ }
+ if(concreteEffects.contains(R)) {
+ Name name = Name.create("R/R", "runR");
+ SCLValue transactionFunction = environment.getValue(name);
+ if(transactionFunction == null) {
+ errorLog.log(expression.location, "Cannot locate " + name);
+ return expression;
+ }
+
+ expression = decorate(transactionFunction, R, expression);
+ }
+ if(concreteEffects.contains(Types.RANDOM)) {
+ Name name = Name.create("Random", "runRandom");
+ SCLValue transactionFunction = environment.getValue(name);
+ if(transactionFunction == null) {
+ errorLog.log(expression.location, "Cannot locate " + name);
+ return expression;
+ }
+
+ expression = decorate(transactionFunction, Types.RANDOM, expression);
+ }
+ return expression;
+ }
+
+ @Override
+ public boolean decorateSubstructure(Expression expression) {
+ if(expression instanceof ELambda || expression instanceof ESimpleLambda)
+ return false;
+ return true;
+ }
+
+}