From: Hannu Niemistö <hannu.niemisto@semantum.fi>
Date: Thu, 5 Oct 2017 05:21:13 +0000 (+0300)
Subject: Fixed incorrect interaction of EAmbigious and TMetaVar.setRef
X-Git-Tag: v1.31.0~140
X-Git-Url: https://gerrit.simantics.org/r/gitweb?a=commitdiff_plain;h=5bed099be36a76e204265abb2f471d84050c0d66;p=simantics%2Fplatform.git

Fixed incorrect interaction of EAmbigious and TMetaVar.setRef

refs #7530

Change-Id: I6b06e164861fd5eaf7dba9377311106133dd775f
---

diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EAmbiguous.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EAmbiguous.java
index 1d17281dd..0afb14b89 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EAmbiguous.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EAmbiguous.java
@@ -56,7 +56,7 @@ public class EAmbiguous extends SimplifiableExpression {
         THashMap<TMetaVar,Type> unifications = new THashMap<TMetaVar,Type>(); 
         Type requiredType = getType();
         if(DEBUG)
-            System.out.println("EAmbigious.filterActive with " + requiredType);
+            System.out.println("EAmbigious.filterActive with " + requiredType.toStringSkeleton());
         for(int i=0;i<alternatives.length;++i)
             if(active[i]) {
                 unifications.clear();
@@ -117,12 +117,12 @@ public class EAmbiguous extends SimplifiableExpression {
     
     private void listenType() {
         if(DEBUG)
-            System.out.println("EAmbigious.listenType " + getType());
+            System.out.println("EAmbigious.listenType " + getType().toStringSkeleton());
         new TypeListener() {
             @Override
             public void notifyAboutChange() {
                 if(DEBUG)
-                    System.out.println("EAmbigious.notifyAboutChange " + getType());
+                    System.out.println("EAmbigious.notifyAboutChange " + getType().toStringSkeleton());
                 Type requiredType = getType();
                 filterActive();
                 if(activeCount == 0) {
diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TFun.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TFun.java
index 6fc9b42b2..620ef1830 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TFun.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TFun.java
@@ -57,7 +57,7 @@ public class TFun extends Type {
     public TypeAst toTypeAst(TypeUnparsingContext context) {
         TypeAst domainAst = domain.toTypeAst(context);
         TypeAst rangeAst = range.toTypeAst(context);
-        if(Types.canonical(effect) != Types.NO_EFFECTS)
+        if(Types.canonical(effect) != Types.NO_EFFECTS && !context.showSkeletons)
             rangeAst = new TEffectAst(effect.toTypeAst(context), rangeAst);
         Type dom = Types.canonical(domain);
         if(dom instanceof TPred)
diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TMetaVar.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TMetaVar.java
index 00b289f46..1596467bc 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TMetaVar.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TMetaVar.java
@@ -92,10 +92,12 @@ public class TMetaVar extends Type {
 
     @Override
     public TypeAst toTypeAst(TypeUnparsingContext context) {
-        if(ref == null)
-            return new TVarAst(/*polarity.getSymbol() +*/ context.getName(this));
-        else
+        if(ref != null)
             return ref.toTypeAst(context);
+        else if(context.showSkeletons && skeletonRef != null)
+            return skeletonRef.toTypeAst(context);
+        else
+            return new TVarAst(/*polarity.getSymbol() +*/ context.getName(this));
     }
     
     @Override
@@ -168,6 +170,10 @@ public class TMetaVar extends Type {
         // Common case
         if(skeletonRef != null) {
             Skeletons.unifySkeletons(thisSkeleton, type);
+            if(ref != null) {
+                Types.unify(this, type);
+                return;
+            }
         }
         setRefBase(type);
     }
diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Type.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Type.java
index c158cb31b..fd7aef527 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Type.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Type.java
@@ -182,6 +182,12 @@ public abstract class Type {
 
     public abstract Kind getKind(Environment context);
 
-    public abstract Type[] skeletonCanonicalChildren(); 
+    public abstract Type[] skeletonCanonicalChildren();
+
+    public String toStringSkeleton() {
+        TypeUnparsingContext tuc = new TypeUnparsingContext();
+        tuc.showSkeletons = true;
+        return toString(tuc);
+    } 
             
 }
\ No newline at end of file
diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/util/TypeUnparsingContext.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/util/TypeUnparsingContext.java
index a5c44639e..97f23bd9a 100644
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/util/TypeUnparsingContext.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/util/TypeUnparsingContext.java
@@ -6,6 +6,7 @@ public class TypeUnparsingContext {
     
     THashMap<Object, String> names;
     int nameId;
+    public boolean showSkeletons;
     
     public TypeUnparsingContext() {
         this.names = new THashMap<Object, String>();
diff --git a/bundles/org.simantics.scl.runtime/scl/Debug.scl b/bundles/org.simantics.scl.runtime/scl/Debug.scl
index 941120100..858f87c80 100644
--- a/bundles/org.simantics.scl.runtime/scl/Debug.scl
+++ b/bundles/org.simantics.scl.runtime/scl/Debug.scl
@@ -15,6 +15,15 @@ time f = do
     endTime = nanoTime ()
     (result, Java.l2d (endTime-beginTime) * 1e-9)
 
+reportTime :: (<e> a) -> <e> a
+reportTime f = runProc do
+    beginTime = nanoTime ()
+    result = f
+    endTime = nanoTime ()
+    time = Java.l2d (endTime-beginTime) * 1e-9
+    print "time \(time) s"
+    result
+
 """
 Prints the given text and returns
 the second parameter.
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 91ddbc5e9..a61dc965d 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
@@ -196,7 +196,8 @@ public class ModuleRegressionTests extends TestBase {
     @Test public void OverloadedArithmetic2() { test(); }
     @Test public void OverloadedArithmetic3() { test(); }
     @Test public void OverloadedLiterals2() { test(); }
-    @Test public void Overloading1() { test(); }    
+    @Test public void Overloading1() { test(); }
+    @Test public void Overloading4() { test(); }
     @Test public void Parsing() { test(); }
     @Test public void PolymorphicRecursion() { test(); }
     @Test public void PolymorphicRecursion2() { test(); }
diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Overloading4.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Overloading4.scl
new file mode 100644
index 000000000..040e435be
--- /dev/null
+++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Overloading4.scl
@@ -0,0 +1,25 @@
+// module M1
+import "Prelude"
+
+foo :: Integer -> Integer -> Integer
+foo = (+)
+--
+// module M2
+import "Prelude"
+
+foo :: String -> String -> String -> <Proc> ()
+foo a b c = do
+    print a
+    print b
+    print c
+--
+import "Prelude"
+import "M1"
+import "M2"
+
+main = ignore (foo "Hello" "world" "!")
+--
+Hello
+world
+!
+()
\ No newline at end of file