From 10e12242609c3583d188c016f281e5d9b09b2583 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Hannu=20Niemist=C3=B6?= <hannu.niemisto@semantum.fi>
Date: Tue, 6 Feb 2018 14:25:27 +0200
Subject: [PATCH] (refs #7746) Fixed applications with intermediate effects

Change-Id: Ida2b7c8e96cbfd45361838e69900a7307e69e343
(cherry picked from commit e515d1fda563f0fa3b8b71f9099696cf49a06d25)
---
 .../elaboration/expressions/EApply.java       | 59 +++++++++--------
 .../elaboration/expressions/ELambda.java      |  2 +-
 .../printing/ExpressionToStringVisitor.java   |  8 +++
 .../simantics/scl/compiler/types/Types.java   | 63 +++++++++++++++++++
 .../compiler/tests/ModuleRegressionTests.java |  1 +
 .../compiler/tests/scl/TypeInferenceBug2.scl  |  1 +
 .../compiler/tests/scl/TypeInferenceBug3.scl  | 12 ++++
 7 files changed, 120 insertions(+), 26 deletions(-)
 create mode 100644 tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug3.scl

diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EApply.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EApply.java
index 5d915a98d..7f50d730b 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EApply.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EApply.java
@@ -1,6 +1,7 @@
 package org.simantics.scl.compiler.elaboration.expressions;
 
 import java.util.ArrayList;
+import java.util.Arrays;
 
 import org.simantics.scl.compiler.common.names.Name;
 import org.simantics.scl.compiler.common.names.Names;
@@ -28,7 +29,6 @@ import org.simantics.scl.compiler.types.TFun;
 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 org.simantics.scl.compiler.types.util.MultiFunction;
 
@@ -220,14 +220,13 @@ public class EApply extends Expression {
         return new IApply(function.toIExpression(target), parametersI);
     }
     
-    private void inferType(TypingContext context, boolean ignoreResult) {
+    private Expression inferType(TypingContext context, boolean ignoreResult) {
         function = function.inferType(context);
         function = context.instantiate(function);
-        MultiFunction mfun;
-        try {
-            mfun = Types.unifyFunction(function.getType(), parameters.length);
-        } catch (UnificationException e) {
-            int arity = Types.getArity(function.getType());
+        Type functionType = function.getType();
+        
+        int arity = Types.getMaxArity(functionType);
+        if(arity < parameters.length) {
             if(arity == 0)
                 context.getErrorLog().log(location, "Application of non-function.");
             else
@@ -236,40 +235,50 @@ public class EApply extends Expression {
             setType(Types.metaVar(Kinds.STAR));
             for(int i=0;i<parameters.length;++i)
                 parameters[i] = parameters[i].inferType(context);
-            return;
-        }
-        if((ignoreResult && Skeletons.canonicalSkeleton(mfun.returnType) instanceof TFun &&
-                Types.canonical(mfun.effect) == Types.NO_EFFECTS) ||
-                (context.isInPattern() && Skeletons.canonicalSkeleton(mfun.returnType) instanceof TFun)) {
-            context.getErrorLog().log(location, "The function is applied with too few parameters.");
+            return this;
         }
         
-        // Check parameter types
-        for(int i=0;i<parameters.length;++i)
-            parameters[i] = parameters[i].checkType(context, mfun.parameterTypes[i]);
+        EApply current = this;
+        while(true) {
+            MultiFunction mfun = Types.unifyFunction2(functionType, current.parameters.length);
+            int marity = mfun.parameterTypes.length;
+            for(int i=0;i<marity;++i)
+                current.parameters[i] = current.parameters[i].checkType(context, mfun.parameterTypes[i]);
+            current.effect = mfun.effect;
+            context.declareEffect(location, mfun.effect);
+            current.setType(mfun.returnType);
 
-        effect = mfun.effect;
-        
-        context.declareEffect(location, mfun.effect);
-        setType(mfun.returnType);
+            if(marity < current.parameters.length) {
+                Expression[] missingParameters = Arrays.copyOfRange(current.parameters, marity, current.parameters.length);
+                functionType = mfun.returnType;
+                current.parameters = Arrays.copyOf(current.parameters, marity);
+                current = new EApply(current, missingParameters);
+            }
+            else {
+                if((ignoreResult && mfun.effect == Types.NO_EFFECTS && Skeletons.canonicalSkeleton(mfun.returnType) instanceof TFun) ||
+                        (context.isInPattern() && Skeletons.canonicalSkeleton(mfun.returnType) instanceof TFun)) {
+                    context.getErrorLog().log(location, "The function is applied with too few parameters.");
+                }
+                return current;
+            }
+        }
     }
     
     @Override
     public Expression inferType(TypingContext context) {
         if(parameters.length == 2 && function instanceof EConstant && ((EConstant)function).value.getName() == Names.Prelude_dollar)
             return new EApply(location, parameters[0], parameters[1]).inferType(context);
-        inferType(context, false);
-        return this;
+        return inferType(context, false);
     }
     
     @Override
     public Expression checkIgnoredType(TypingContext context) {
         if(parameters.length == 2 && function instanceof EConstant && ((EConstant)function).value.getName() == Names.Prelude_dollar)
             return new EApply(location, parameters[0], parameters[1]).checkIgnoredType(context);
-        inferType(context, true);
+        Expression expression = inferType(context, true);
         if(Types.canonical(getType()) != Types.UNIT)
-            return new ESimpleLet(location, null, this, new ELiteral(NoRepConstant.PUNIT));
-        return this;
+            expression = new ESimpleLet(location, null, expression, new ELiteral(NoRepConstant.PUNIT));
+        return expression;
     }
     
     public Type getLocalEffect() {
diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/ELambda.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/ELambda.java
index b01b77189..e580648de 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/ELambda.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/ELambda.java
@@ -14,7 +14,7 @@ import org.simantics.scl.compiler.types.util.MultiFunction;
 
 public class ELambda extends SimplifiableExpression {
     public Case[] cases;
-    Type effect = Types.NO_EFFECTS;
+    public Type effect = Types.NO_EFFECTS;
     
     public ELambda(Case[] cases) {
         this.cases = cases;
diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/printing/ExpressionToStringVisitor.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/printing/ExpressionToStringVisitor.java
index b1a05d70e..122548fac 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/printing/ExpressionToStringVisitor.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/printing/ExpressionToStringVisitor.java
@@ -73,6 +73,8 @@ import org.simantics.scl.compiler.elaboration.rules.TransformationRule;
 
 public class ExpressionToStringVisitor implements ExpressionVisitor, QueryVisitor {
 
+    public static final boolean SHOW_EFFECTS = false;
+    
     StringBuilder b = new StringBuilder();
     int indentation;
     
@@ -124,6 +126,8 @@ public class ExpressionToStringVisitor implements ExpressionVisitor, QueryVisito
     @Override
     public void visit(EApply expression) {
         showPar(expression.getFunction());
+        if(SHOW_EFFECTS)
+            b.append(" {" + expression.effect + "}");
         for(Expression parameter : expression.getParameters()) {
             b.append(' ');
             showPar(parameter);
@@ -227,6 +231,8 @@ public class ExpressionToStringVisitor implements ExpressionVisitor, QueryVisito
                 showPar(pat);
                 b.append(' ');
             }
+            if(SHOW_EFFECTS)
+                b.append("{" + expression.effect + "} ");
             b.append("-> ");
             ++indentation;
             case_.value.accept(this);
@@ -346,6 +352,8 @@ public class ExpressionToStringVisitor implements ExpressionVisitor, QueryVisito
             b.append(' ');
             show(expression.getParameter());
         }
+        if(SHOW_EFFECTS)
+            b.append(" {" + expression.effect + "}");
         b.append(" -> ");
         expression.getValue().accept(this);
     }
diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Types.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Types.java
index 5512f5e6e..cae38a128 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Types.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Types.java
@@ -6,6 +6,7 @@ import java.util.Arrays;
 import java.util.Collections;
 import java.util.List;
 
+import org.simantics.scl.compiler.common.exceptions.InternalCompilerError;
 import org.simantics.scl.compiler.errors.Locations;
 import org.simantics.scl.compiler.internal.parsing.exceptions.SCLSyntaxErrorException;
 import org.simantics.scl.compiler.internal.parsing.parser.SCLParserImpl;
@@ -643,7 +644,52 @@ public class Types {
                 effect,
                 type);
     }
+    
+    /**
+     * This function always success, but may return a multi function
+     * with arity smaller than given parameter
+     */
+    public static MultiFunction unifyFunction2(Type type, int arity) {
+        type = canonical(type);
 
+        Type[] parameterTypes = new Type[arity];
+        Type effect = Types.NO_EFFECTS;
+        int i;
+        for(i=0;i<arity;++i) {
+            if(type instanceof TFun) {
+                TFun fun = (TFun)type;
+                parameterTypes[i] = fun.getCanonicalDomain();
+                type = fun.getCanonicalRange();
+                effect = fun.getCanonicalEffect();
+                if(effect != Types.NO_EFFECTS) {
+                    ++i;
+                    break;
+                }
+            }
+            else if(type instanceof TMetaVar) {
+                Type domain = metaVar(Kinds.STAR);
+                parameterTypes[i] = domain;
+                Type range = metaVar(Kinds.STAR);
+                effect = metaVar(Kinds.EFFECT);
+                try {
+                    ((TMetaVar) type).setRef(functionE(domain, effect, range));
+                } catch (UnificationException e) {
+                    // Should never happen, if we have checked maximum arity before calling this function
+                    throw new InternalCompilerError(e);
+                }
+                type = range;
+                ++i;
+                break;
+            }
+            else
+                break;
+        }
+        
+        if(i < arity)
+            parameterTypes = Arrays.copyOf(parameterTypes, i);
+        return new MultiFunction(parameterTypes, effect, type);
+    }
+    
     public static MultiFunction unifyFunction(Type type, int arity) throws UnificationException {
         Type[] parameterTypes = new Type[arity];
         for(int i=0;i<arity;++i)
@@ -693,6 +739,23 @@ public class Types {
         }
         return arity;
     }
+    
+    public static int getMaxArity(Type type) {
+        type = Skeletons.canonicalSkeleton(type);
+        int arity = 0;
+        while(true) {
+            if(type instanceof TFun) {
+                ++arity;
+                type = Skeletons.canonicalSkeleton(((TFun) type).getCanonicalRange());
+            }
+            else if(type instanceof TMetaVar) {
+                return Integer.MAX_VALUE;
+            }
+            else
+                break;
+        }
+        return arity;
+    }
 
     public static TMetaVar metaVar(Kind kind) {
         return new TMetaVar(kind);
diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/ModuleRegressionTests.java b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/ModuleRegressionTests.java
index e11755fc3..6c1783027 100644
--- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/ModuleRegressionTests.java
+++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/ModuleRegressionTests.java
@@ -283,6 +283,7 @@ public class ModuleRegressionTests extends TestBase {
     @Test public void TypeClass() { test(); }    
     @Test public void TypeClassBug1() { test(); }
     @Test(timeout=1000L) public void TypeInferenceBug2() { test(); }
+    @Test public void TypeInferenceBug3() { test(); }
     @Test public void TypeOf1() { test(); }
     @Test public void TypingBug1() { test(); }
     @Test public void TypingError1() { test(); }
diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug2.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug2.scl
index e8c80551f..5ea916b1e 100644
--- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug2.scl
+++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug2.scl
@@ -4,4 +4,5 @@ distance (x1,y1) (x2,y2) = let dx = x1-x2
                                dy = y1-y2
                            in sqrt (dx*dx + dy*dy) print x1
 --
+5:31-5:35: Constrain Real ((a -> <Proc> ()) -> <e> b -> <d> c) contains free variables not mentioned in the type of the value.
 5:58-5:60: Expected <a> got <b>.
\ No newline at end of file
diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug3.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug3.scl
new file mode 100644
index 000000000..657183c79
--- /dev/null
+++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug3.scl
@@ -0,0 +1,12 @@
+import "Prelude"
+
+foo :: Integer -> <Proc> (Integer -> <Proc> ())
+foo i = do
+    print i
+    \j -> print j
+
+main = foo 3 4
+--
+3
+4
+()
\ No newline at end of file
-- 
2.47.1