(refs #7498) Bugfixing implementation of skeleton refs

Change-Id: If396a5e40fdcb08ce0911115ac44fb516fc2bea7

diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TypingContext.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TypingContext.java
index ac004eab692a062e0777c0ebd1d8c3dab3329087..410ec0213fd5949720cc45dc13d924017bb86a19 100644 (file)
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TypingContext.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TypingContext.java
@@ -22,6 +22,7 @@ import org.simantics.scl.compiler.internal.elaboration.constraints.ExpressionAug
 import org.simantics.scl.compiler.internal.elaboration.constraints.ReducedConstraints;
 import org.simantics.scl.compiler.internal.elaboration.subsumption.SubSolver;
 import org.simantics.scl.compiler.internal.elaboration.subsumption.Subsumption;
+import org.simantics.scl.compiler.types.Skeletons;
 import org.simantics.scl.compiler.types.TApply;
 import org.simantics.scl.compiler.types.TCon;
 import org.simantics.scl.compiler.types.TForAll;
@@ -116,8 +117,10 @@ public class TypingContext {
         
         if(a instanceof TMetaVar) {
             TMetaVar aVar = (TMetaVar)a;
-            if(b instanceof TMetaVar) 
+            if(b instanceof TMetaVar) {
+                Skeletons.unifySkeletons(a, b);
                 subsumptions.add(new Subsumption(loc, a, b));
+            }
             else {
                 if(b.contains(aVar))
                     throw new UnificationException(a, b);
@@ -182,6 +185,11 @@ public class TypingContext {
         else if(type instanceof TMetaVar) {
             TMetaVar var = (TMetaVar)type;
             TMetaVar newVar = Types.metaVar(var.getKind());
+            try {
+                newVar.setSkeletonRef(var);
+            } catch (UnificationException e) {
+                throw new InternalCompilerError(loc, e);
+            }
             subsumptions.add(new Subsumption(loc, newVar, var));
             return newVar;
         }
@@ -232,6 +240,11 @@ public class TypingContext {
         else if(type instanceof TMetaVar) {
             TMetaVar var = (TMetaVar)type;
             TMetaVar newVar = Types.metaVar(var.getKind());
+            try {
+                newVar.setSkeletonRef(var);
+            } catch (UnificationException e) {
+                throw new InternalCompilerError(loc, e);
+            }
             subsumptions.add(new Subsumption(loc, var, newVar));
             return newVar;
         }
@@ -372,7 +385,7 @@ public class TypingContext {
                 Types.unify(sub.a, sub.b);
             } catch (UnificationException e) {
                 // Should not happen. Both types should be metavars.
-                throw new InternalCompilerError();
+                throw new InternalCompilerError(e);
             }
         subsumptions.clear();
         return true;

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 09397ba058a297f7c3ce8c146eb8a28e5cad9613..1d17281dd2935462388044641156fb2699125e93 100644 (file)
--- 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
@@ -177,14 +177,19 @@ public class EAmbiguous extends SimplifiableExpression {
         if(resolvedExpression != null)
             return resolvedExpression;
         else {
+            if(DEBUG)
+                System.out.println("EAmbigious.simplify: error");
             context.getErrorLog().log(location, getAmbiguousDescription(getType()));
             return this;
         }
     }
     
     public void assertResolved(ErrorLog errorLog) {
-        if(resolvedExpression == null)
+        if(resolvedExpression == null) {
+            if(DEBUG)
+                System.out.println("EAmbigious.assertResolved: error");
             errorLog.log(location, getAmbiguousDescription(getType()));
+        }
     }
     
     @Override

diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Skeletons.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Skeletons.java
index b7266ef7efb7514a6de9adadba17b2c65392af13..2b99c28a6a9c041177b793f411acdd3a1548758e 100644 (file)
--- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Skeletons.java
+++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Skeletons.java
@@ -17,7 +17,7 @@ public class Skeletons {
             if(metaVar.ref != null)
                 type = metaVar.ref;
             else if(metaVar.skeletonRef != null)
-                type = metaVar.skeletonRef;
+                return metaVar.skeletonRef = canonicalSkeleton(metaVar.skeletonRef);
             else
                 return metaVar;
         }

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 d78d745eb670c0ccb99719c2690e314e6a610488..00b289f46a1f1b934c5ab271386fedde11f38554 100644 (file)
--- 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
@@ -2,6 +2,7 @@ package org.simantics.scl.compiler.types;
 
 import java.util.ArrayList;
 
+import org.simantics.databoard.util.IdentityHashSet;
 import org.simantics.scl.compiler.common.exceptions.InternalCompilerError;
 import org.simantics.scl.compiler.environment.Environment;
 import org.simantics.scl.compiler.internal.types.HashCodeUtils;
@@ -134,27 +135,112 @@ public class TMetaVar extends Type {
     }
 
     public void setRef(Type type) throws UnificationException {
-        if(type instanceof TMetaVar && ((TMetaVar)type).ref != null)
-            throw new InternalCompilerError("Not canonical!");
+        //System.out.println("----");
+        //System.out.println("this = " + refStructure(this));
+        //System.out.println("type = " + refStructure(type));
         if(type == this)
             throw new InternalCompilerError("Illegal setRef");
         if(DEBUG)
             System.out.println("setRef " + System.identityHashCode(this) + " -> " + type);
         if(ref != null)
             throw new InternalCompilerError("Method setRef should be called only for unbound meta variables.");
-        if(type.contains(this))
+        Type thisSkeleton = Skeletons.canonicalSkeleton(this);
+
+        if(type instanceof TMetaVar) {
+            TMetaVar other = (TMetaVar)type;
+            if(other.ref != null)
+                throw new InternalCompilerError("Not canonical!");
+            
+            Type typeSkeleton = Skeletons.canonicalSkeleton(type);
+            if(thisSkeleton == typeSkeleton) {
+                if(skeletonRef != null)
+                    setRefBase(type);
+                else
+                    other.setRefBase(this);
+                return;
+            }
+            else if(thisSkeleton instanceof TMetaVar && type.contains((TMetaVar)thisSkeleton))
+                throw new UnificationException(this, type);
+        }
+        else if(thisSkeleton instanceof TMetaVar && type.contains((TMetaVar)thisSkeleton))
             throw new UnificationException(this, type);
+        
+        // Common case
+        if(skeletonRef != null) {
+            Skeletons.unifySkeletons(thisSkeleton, type);
+        }
+        setRefBase(type);
+    }
+    
+    private void setRefBase(Type type) throws UnificationException {
+        skeletonRef = null;
         ref = type;
         if(polarity != Polarity.NO_POLARITY)
             type.addPolarity(polarity);
-        if(skeletonRef != null) {
-            Type skeleton = skeletonRef;
-            skeletonRef = null;
-            Skeletons.unifySkeletons(skeleton, type);
-        }
+        //System.out.println("result = " + refStructure(this));
+        //checkRefLoop(this);
         fireNotifyAboutChange();
     }
     
+    private static String refStructure(Type t) {
+        StringBuilder b = new StringBuilder();
+        IdentityHashSet<TMetaVar> seenVars = new IdentityHashSet<TMetaVar>();
+        refType(b, t, seenVars);
+        return b.toString();
+    }
+
+    private void refStructure(StringBuilder b, IdentityHashSet<TMetaVar> seenVars) {
+        b.append(System.identityHashCode(this));
+        if(!seenVars.add(this))
+            b.append(" (loop)");
+        else if(ref != null) {
+            b.append(" => ");
+            refType(b, ref, seenVars);
+        }
+        else if(skeletonRef != null) {
+            b.append(" -> ");
+            refType(b, skeletonRef, seenVars);
+        }
+        else
+            b.append(" (canonical)");
+    }
+
+    private static void refType(StringBuilder b, Type t, IdentityHashSet<TMetaVar> seenVars) {
+        if(t instanceof TMetaVar)
+            ((TMetaVar)t).refStructure(b, seenVars);
+        else {
+            b.append('[');
+            t.toString(new TypeUnparsingContext(), b);
+            b.append(']');
+        }
+    }
+
+    private void checkRefLoop(TMetaVar var) {
+        IdentityHashSet<TMetaVar> seenVars = new IdentityHashSet<TMetaVar>();
+        StringBuilder b = new StringBuilder();
+        while(true) {
+            b.append(var);
+            if(!seenVars.add(var))
+                throw new InternalCompilerError("Cyclic meta var references: " + b);
+            if(var.ref != null) {
+                b.append(" => ");
+                if(var.ref instanceof TMetaVar)
+                    var = (TMetaVar)var.ref;
+                else
+                    return;
+            }
+            else if(var.skeletonRef != null) {
+                b.append(" -> ");
+                if(var.skeletonRef instanceof TMetaVar)
+                    var = (TMetaVar)var.skeletonRef;
+                else
+                    return;
+            }
+            else
+                return;
+        }
+    }
+
     public Type getRef() {
         return ref;
     }
@@ -273,6 +359,7 @@ public class TMetaVar extends Type {
         if(type.contains(this))
             throw new UnificationException(this, type);
         this.skeletonRef = type;
+        //checkRefLoop(this);
         fireNotifyAboutChange();
     }
     

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 275bba86e8d1a945283b843ad9c4afdbc388bb26..9eb49d2f7a27668a5f1105b4275d2fdbef7c062c 100644 (file)
--- 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
@@ -208,6 +208,7 @@ public class ModuleRegressionTests extends TestBase {
     @Test public void RangeSyntax() { test(); }
     @Test public void Record1() { test(); }
     @Test public void Record2() { test(); }
+    @Test public void Record3() { test(); }
     @Test public void RecordShorthand() { test(); }
     @Test public void RecursionBug() { test(); }
     @Test public void RecursiveContext() { test(); }

diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/FoldMissingInitialValue.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/FoldMissingInitialValue.scl
index 5d68c4c06c66985cbc810b9938ceea332b2c0c24..d188d8f9a6617e4d081794ef9ad8bae2f7146ff7 100644 (file)
--- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/FoldMissingInitialValue.scl
+++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/FoldMissingInitialValue.scl
@@ -2,4 +2,4 @@ import "Prelude"
 
 f p l = (foldl (+) (map ((+)p) l)) + p
 --
-3:25-3:31: Type [a b] -> <c> a b is not a subtype of a.
\ No newline at end of file
+3:38-3:39: Expected <[a] -> <d> b c> got <e>.
\ No newline at end of file

diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/PolymorphicRecursion.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/PolymorphicRecursion.scl
index b37ff02831ef35ba300c79e29de23a40963ae014..ba5df53f474d05eb93beeedb43819906a8b70180 100644 (file)
--- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/PolymorphicRecursion.scl
+++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/PolymorphicRecursion.scl
@@ -11,6 +11,5 @@ cons x (Zero ps)  = One x ps
 cons x (One y ps) = Zero (cons (x, y) ps)
 --
 11:21-11:42: Expected <Vec (a, a)> got <Vec a>.
-11:33-11:34: Type (a, a) is not a subtype of a.
-11:36-11:37: Type (a, a) is not a subtype of a.
+11:32-11:38: Expected <a> got <(b, c)>.
 11:39-11:41: Expected <Vec a> got <Vec (a, a)>.
\ No newline at end of file

diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Record3.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Record3.scl
new file mode 100644 (file)
index 0000000..3e14cf7
--- /dev/null
+++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Record3.scl
@@ -0,0 +1,14 @@
+module {
+    features = [fields]
+}
+
+import "Prelude"
+
+data Foo = Foo { x :: Double }
+data Bar = Bar { x :: Double, y :: Double }
+
+main = sum $ map (\v -> v.x) l
+  where
+    l = [Foo 1.0, Foo 2.0]
+-- 
+3.0
\ No newline at end of file

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 d224b3da6b53b7953495183cc7030ecd12165d95..e8c80551f6761ff8c723a4ae1ac754ce61c45e86 100644 (file)
--- 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,6 +4,4 @@ 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 -> <b> ()) -> ((c -> <d> ()) -> <h> e -> <g> f) -> <j> i) contains free variables not mentioned in the type of the value.
-5:52-5:57: Constrain Show a contains free variables not mentioned in the type of the value.
-5:58-5:60: Unification of types failed.
\ No newline at end of file
+5:58-5:60: Expected <a> got <b>.
\ No newline at end of file