]> gerrit.simantics Code Review - simantics/platform.git/blob - bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/top/ToplevelEffectDecorator.java
New type class MonadE and corresponding monad syntax with edo keyword
[simantics/platform.git] / bundles / org.simantics.scl.compiler / src / org / simantics / scl / compiler / top / ToplevelEffectDecorator.java
1 package org.simantics.scl.compiler.top;
2
3 import java.util.ArrayList;
4
5 import org.simantics.scl.compiler.common.names.Name;
6 import org.simantics.scl.compiler.common.names.Names;
7 import org.simantics.scl.compiler.elaboration.expressions.Case;
8 import org.simantics.scl.compiler.elaboration.expressions.EApply;
9 import org.simantics.scl.compiler.elaboration.expressions.ECHRRuleset;
10 import org.simantics.scl.compiler.elaboration.expressions.EConstant;
11 import org.simantics.scl.compiler.elaboration.expressions.EEnforce;
12 import org.simantics.scl.compiler.elaboration.expressions.EFieldAccess;
13 import org.simantics.scl.compiler.elaboration.expressions.ELambda;
14 import org.simantics.scl.compiler.elaboration.expressions.ERuleset;
15 import org.simantics.scl.compiler.elaboration.expressions.ESelect;
16 import org.simantics.scl.compiler.elaboration.expressions.ESimpleLambda;
17 import org.simantics.scl.compiler.elaboration.expressions.EWhen;
18 import org.simantics.scl.compiler.elaboration.expressions.Expression;
19 import org.simantics.scl.compiler.elaboration.expressions.Variable;
20 import org.simantics.scl.compiler.elaboration.expressions.visitors.StandardExpressionTransformer;
21 import org.simantics.scl.compiler.elaboration.modules.SCLValue;
22 import org.simantics.scl.compiler.environment.Environment;
23 import org.simantics.scl.compiler.errors.ErrorLog;
24 import org.simantics.scl.compiler.errors.Locations;
25 import org.simantics.scl.compiler.types.TCon;
26 import org.simantics.scl.compiler.types.Type;
27 import org.simantics.scl.compiler.types.Types;
28
29 import gnu.trove.map.hash.THashMap;
30
31 public class ToplevelEffectDecorator extends StandardExpressionTransformer {
32
33     ErrorLog errorLog;
34     Environment environment;
35
36     public ToplevelEffectDecorator(ErrorLog errorLog, Environment environment) {
37         this.errorLog = errorLog;
38         this.environment = environment;
39     }
40
41     @Override
42     public Expression transform(EEnforce expression) {
43         return decorateByEffect(expression, expression.getEffect());
44     }
45     
46     @Override
47     public Expression transform(EWhen expression) {
48         return decorateByEffect(expression, expression.getEffect());
49     }
50     
51     @Override
52     public Expression transform(ERuleset expression) {
53         return decorateByEffect(expression, expression.getEffect());
54     }
55     
56     @Override
57     public Expression transform(ECHRRuleset expression) {
58         return decorateByEffect(expression, expression.getEffect());
59     }
60     
61     @Override
62     public Expression transform(EFieldAccess expression) {
63         // Can we encounter EFieldAccess in this transformer?
64         return decorateByEffect(expression, expression.getEffect());
65     }
66     
67     @Override
68     public Expression transform(ESelect expression) {
69         return decorateByEffect(expression, expression.getEffect());
70     }
71
72     @Override
73     public Expression transform(EApply expression) {
74         return decorateByEffect(super.transform(expression), expression.getLocalEffect());
75     }
76
77     @Override
78     public Expression transform(ESimpleLambda expression) {
79         // Never has side effects
80         return expression;
81     }
82
83     @Override
84     public Expression transform(ELambda expression) {
85         // Never has side effects
86         return expression;
87     }
88
89     @Override
90     protected void transformCases(Case[] cases) {
91         for(Case case_ : cases)
92             case_.value = case_.value.accept(this);
93     }
94     
95     private static final THashMap<TCon, Name> DECORATION_MAP = new THashMap<TCon, Name>();
96
97     static {
98         DECORATION_MAP.put(Types.WRITE_GRAPH,     Names.Simantics_DB_syncWrite);
99         DECORATION_MAP.put(Types.READ_GRAPH,      Names.Simantics_DB_syncRead);
100         DECORATION_MAP.put(Types.con("R/R", "R"), Names.R_R_runR);
101         DECORATION_MAP.put(Types.RANDOM,          Names.Random_runRandom);
102     }
103
104     private Expression decorateByEffect(Expression expression, Type effect) {
105         if(effect == Types.NO_EFFECTS) 
106             return expression;
107
108         ArrayList<TCon> concreteEffects = new ArrayList<TCon>();
109         effect.collectConcreteEffects(concreteEffects);
110         for(TCon ce : concreteEffects) {
111             Name transactionFunctionName = DECORATION_MAP.get(ce);
112             if(transactionFunctionName == null)
113                 continue;
114             SCLValue transactionFunction = environment.getValue(transactionFunctionName);
115             if(transactionFunction == null) {
116                 errorLog.log(expression.location, "Cannot locate " + transactionFunctionName);
117                 continue;
118             }
119             expression = decorate(transactionFunction, ce, expression);
120         }
121
122         return expression;
123     }
124
125     private static Expression decorate(SCLValue transactionFunction, Type effect, Expression expression) {
126         Variable var = new Variable("_");
127         var.setType(effect == Types.RANDOM ? Types.PUNIT : Types.UNIT);
128         Expression trans = new EApply(expression.getLocation(), Types.PROC,
129                 effect == Types.RANDOM ? new EConstant(transactionFunction, Types.PROC, expression.getType()) : new EConstant(transactionFunction, expression.getType()),
130                 new ESimpleLambda(Locations.NO_LOCATION, var, effect, expression)
131                 );
132         if(expression instanceof EApply) {
133             EApply apply = (EApply)expression;
134             trans = apply.toANormalForm(trans);
135         }
136         return trans;
137     }
138 }