X-Git-Url: https://gerrit.simantics.org/r/gitweb?a=blobdiff_plain;f=bundles%2Forg.simantics.scl.compiler%2Fsrc%2Forg%2Fsimantics%2Fscl%2Fcompiler%2Felaboration%2Fexpressions%2FEBind.java;h=84cc220c1a0222e75def8781fe657eaff1a88aa3;hb=34656219dde2130ecbeedd274ddd83c6df5699e0;hp=3bec2aaa13ecafde91be4380559df456779b6953;hpb=a9f88c57e622d9ecf2732bd0278e0989dc0dfd5a;p=simantics%2Fplatform.git

diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EBind.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EBind.java
index 3bec2aaa1..84cc220c1 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EBind.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EBind.java
@@ -1,56 +1,51 @@
 package org.simantics.scl.compiler.elaboration.expressions;
 
 import org.simantics.scl.compiler.common.exceptions.InternalCompilerError;
+import org.simantics.scl.compiler.common.names.Names;
 import org.simantics.scl.compiler.compilation.CompilationContext;
 import org.simantics.scl.compiler.elaboration.contexts.SimplificationContext;
 import org.simantics.scl.compiler.elaboration.contexts.TranslationContext;
 import org.simantics.scl.compiler.elaboration.contexts.TypingContext;
+import org.simantics.scl.compiler.elaboration.expressions.block.BlockType;
 import org.simantics.scl.compiler.elaboration.modules.SCLValue;
 import org.simantics.scl.compiler.errors.Locations;
 import org.simantics.scl.compiler.internal.codegen.references.IVal;
 import org.simantics.scl.compiler.internal.codegen.writer.CodeWriter;
+import org.simantics.scl.compiler.internal.header.ModuleHeader;
 import org.simantics.scl.compiler.types.Type;
 import org.simantics.scl.compiler.types.Types;
 import org.simantics.scl.compiler.types.exceptions.MatchException;
 import org.simantics.scl.compiler.types.exceptions.UnificationException;
 import org.simantics.scl.compiler.types.kinds.Kinds;
 
-import gnu.trove.map.hash.TObjectIntHashMap;
-import gnu.trove.set.hash.THashSet;
-import gnu.trove.set.hash.TIntHashSet;
-
 public class EBind extends SimplifiableExpression {
+    BlockType blockType;
     public Expression pattern;
     public Expression value;
     public Expression in;
-    EVariable monadEvidence;
-    SCLValue bindFunction;
+    public EVariable monadEvidence;
     Type monadType;
+    Type effect;
     Type valueContentType;
     Type inContentType;
     
-    public EBind(long loc, Expression pattern, Expression value, Expression in) {
+    public EBind(long loc, BlockType blockType, Expression pattern, Expression value, Expression in) {
         super(loc);
+        this.blockType = blockType;
         this.pattern = pattern;
         this.value = value;
         this.in = in;
     }
 
-    public EBind(long loc, Expression pattern, Expression value, Expression in,
+    public EBind(long loc, BlockType blockType, Expression pattern, Expression value, Expression in,
             SCLValue bindFunction) {
         super(loc);
+        this.blockType = blockType;
         this.pattern = pattern;
         this.value = value;
         this.in = in;
     }
     
-    @Override
-    public void collectVars(TObjectIntHashMap<Variable> allVars,
-            TIntHashSet vars) {
-        value.collectVars(allVars, vars);
-        in.collectVars(allVars, vars);
-    }
-    
     @Override
     protected void updateType() throws MatchException {
         setType(in.getType());
@@ -58,7 +53,11 @@ public class EBind extends SimplifiableExpression {
     
     @Override
     public Expression checkBasicType(TypingContext context, Type requiredType) {
+        ModuleHeader header = context.getCompilationContext().header;
+        boolean edo = header != null && header.edo;
+        
         monadType = Types.metaVar(Kinds.STAR_TO_STAR);
+        
         inContentType = Types.metaVar(Kinds.STAR);
         Type monadContent = Types.apply(monadType, inContentType);
         try {
@@ -69,7 +68,7 @@ public class EBind extends SimplifiableExpression {
         }
         
         Variable variable = new Variable("monadEvidence");
-        variable.setType(Types.pred(Types.MONAD, monadType));
+        variable.setType(Types.pred(blockType == BlockType.MonadE ? Types.MONAD_E : Types.MONAD, monadType));
         monadEvidence = new EVariable(getLocation(), variable);
         monadEvidence.setType(variable.getType());
         context.addConstraintDemand(monadEvidence);
@@ -77,7 +76,13 @@ public class EBind extends SimplifiableExpression {
         pattern = pattern.checkTypeAsPattern(context, Types.metaVar(Kinds.STAR));
         valueContentType = pattern.getType();
         value = value.checkType(context, Types.apply(monadType, valueContentType));
+        if(edo)
+            context.pushEffectUpperBound(location, blockType == BlockType.Monad ? Types.NO_EFFECTS : Types.metaVar(Kinds.EFFECT));
         in = in.checkType(context, requiredType);
+        if(edo)
+            effect = context.popEffectUpperBound();
+        else
+            effect = Types.NO_EFFECTS;
         Type inType = in.getType();
         setType(inType);
         return this;
@@ -93,16 +98,19 @@ public class EBind extends SimplifiableExpression {
      */
     @Override
     public Expression simplify(SimplificationContext context) {    
-        value = value.simplify(context);
-        in = in.simplify(context);
-        pattern = pattern.simplify(context);
-        
         long loc = getLocation();
-        Expression simplified = new EApply(loc,
-                new EConstant(loc, bindFunction, Types.canonical(monadType), Types.canonical(valueContentType), Types.canonical(inContentType)),
+        monadType = Types.canonical(monadType);
+        valueContentType = Types.canonical(valueContentType);
+        effect = Types.canonical(effect);
+        inContentType = Types.canonical(inContentType);
+        Type[] types = blockType == BlockType.MonadE 
+                ? new Type[] {monadType, valueContentType, effect, inContentType} 
+                : new Type[] {monadType, valueContentType, inContentType};
+        Expression simplified = new EApply(loc, effect,
+                new EConstant(loc, context.getValue(blockType == BlockType.MonadE ? Names.Prelude_bindE : Names.Prelude_bind), types),
                 monadEvidence, 
                 value,
-                new ELambda(loc, new Case[] {
+                new ELambda(loc, effect, new Case[] {
                     new Case(new Expression[] { pattern }, in)
                 }));
         simplified.setType(getType());
@@ -110,13 +118,6 @@ public class EBind extends SimplifiableExpression {
         return simplified.simplify(context);
     }
 
-    @Override
-    public void collectFreeVariables(THashSet<Variable> vars) {
-        in.collectFreeVariables(vars);
-        value.collectFreeVariables(vars);
-        pattern.removeFreeVariables(vars);
-    }
-
     @Override
     public Expression resolve(TranslationContext context) {
         value = value.resolve(context);
@@ -126,18 +127,9 @@ public class EBind extends SimplifiableExpression {
         in = in.resolve(context);
         context.popFrame();
         
-        bindFunction = context.getBindFunction();
-        
         return this; 
     }
     
-    @Override
-    public void collectEffects(THashSet<Type> effects) {
-        pattern.collectEffects(effects);
-        value.collectEffects(effects);
-        in.collectEffects(effects);
-    }
-    
     @Override
     public void setLocationDeep(long loc) {
         if(location == Locations.NO_LOCATION) {