X-Git-Url: https://gerrit.simantics.org/r/gitweb?p=simantics%2Fplatform.git;a=blobdiff_plain;f=bundles%2Forg.simantics.scl.compiler%2Fsrc%2Forg%2Fsimantics%2Fscl%2Fcompiler%2Ftop%2FToplevelEffectDecorator.java;fp=bundles%2Forg.simantics.scl.compiler%2Fsrc%2Forg%2Fsimantics%2Fscl%2Fcompiler%2Ftop%2FToplevelEffectDecorator.java;h=56325d513e58d6f32e244d6ff2adb2515f649bbe;hp=0000000000000000000000000000000000000000;hb=969bd23cab98a79ca9101af33334000879fb60c5;hpb=866dba5cd5a3929bbeae85991796acb212338a08

diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/top/ToplevelEffectDecorator.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/top/ToplevelEffectDecorator.java
new file mode 100644
index 000000000..56325d513
--- /dev/null
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/top/ToplevelEffectDecorator.java
@@ -0,0 +1,124 @@
+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;
+    }
+
+}