X-Git-Url: https://gerrit.simantics.org/r/gitweb?p=simantics%2Fplatform.git;a=blobdiff_plain;f=bundles%2Forg.simantics.scl.compiler%2Fsrc%2Forg%2Fsimantics%2Fscl%2Fcompiler%2Ftypes%2FTypes.java;h=e1b89eece28ab21f14e87e3e2fd20745ec85e7c5;hp=f0c9dbddfb2e1383ff746aa9b1a1ce7f1f12e552;hb=e515d1fda563f0fa3b8b71f9099696cf49a06d25;hpb=eecd74faded034bd067094b42bbac0d286d8d9fa

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 f0c9dbddf..e1b89eece 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;
@@ -57,15 +58,6 @@ public class Types {
     public static final TCon LONG = con(BUILTIN, "Long");
     public static final TCon FLOAT = con(BUILTIN, "Float");
     public static final TCon DOUBLE = con(BUILTIN, "Double");
-    
-    public static final TCon BOOLEAN_ARRAY = con(BUILTIN, "BooleanArray");
-    public static final TCon BYTE_ARRAY = con(BUILTIN, "ByteArray");
-    public static final TCon CHARACTER_ARRAY = con(BUILTIN, "CharacterArray");
-    public static final TCon SHORT_ARRAY = con(BUILTIN, "ShortArray");
-    public static final TCon INTEGER_ARRAY = con(BUILTIN, "IntegerArray");
-    public static final TCon LONG_ARRAY = con(BUILTIN, "LongArray");
-    public static final TCon FLOAT_ARRAY = con(BUILTIN, "FloatArray");
-    public static final TCon DOUBLE_ARRAY = con(BUILTIN, "DoubleArray");
 
     public static final TCon STRING = con(BUILTIN, "String");
     public static final TCon ARROW = con(BUILTIN, "->");
@@ -84,21 +76,23 @@ public class Types {
     public static final TCon TYPEABLE = con(BUILTIN, "Typeable");
     public static final TCon SERIALIZABLE = con(BUILTIN, "Serializable");
     public static final TCon VEC_COMP = con(BUILTIN, "VecComp");
+    public static final TCon CLASS = con(BUILTIN, "Class");
     public static final TCon BINDING = con(BUILTIN, "Binding");
 
+    public static final TCon TYPE = con(BUILTIN, "Type");
+    
     public static final TCon DYNAMIC = con("Prelude", "Dynamic");
     public static final TCon VARIANT = con(BUILTIN, "Variant");
     
     public static final TCon ADDITIVE = con("Prelude", "Additive");
     public static final TCon MONAD = con("Prelude", "Monad");
+    public static final TCon MONAD_E = con("Prelude", "MonadE");
     public static final TCon INTEGRAL = con("Prelude", "Integral");
     public static final TCon RING = con("Prelude", "Ring");
     public static final TCon ORDERED_RING = con("Prelude", "OrderedRing");
     public static final TCon REAL = con("Prelude", "Real");
     public static final TCon SHOW = con("Prelude", "Show");
-    public static final TCon EQ = con("Prelude", "Eq");
     public static final TCon ORD = con("Prelude", "Ord");
-    public static final TCon HASHABLE = con("Prelude", "Hashable");
     public static final TCon IO = con("Serialization", "IO");
 
     public static final Type REF = con("Prelude", "Ref");
@@ -110,8 +104,20 @@ public class Types {
     
     public static final TUnion NO_EFFECTS = new TUnion();
     public static final TCon PROC = con(BUILTIN, "Proc");
+    public static final TCon EXCEPTION = con(BUILTIN, "Exception");
     
     public static final TCon BRANCH_POINT = con(BUILTIN, "BranchPoint");
+    
+    public static final TCon CHRContext = con(BUILTIN, "CHRContext");
+
+    public static final Type BOOLEAN_ARRAY = vector(BOOLEAN);
+    public static final Type BYTE_ARRAY = vector(BYTE);
+    public static final Type CHARACTER_ARRAY = vector(CHARACTER);
+    public static final Type SHORT_ARRAY = vector(SHORT);
+    public static final Type INTEGER_ARRAY = vector(INTEGER);
+    public static final Type LONG_ARRAY = vector(LONG);
+    public static final Type FLOAT_ARRAY = vector(FLOAT);
+    public static final Type DOUBLE_ARRAY = vector(DOUBLE);
 
     private volatile static TCon[] tupleCache = new TCon[] {
         UNIT, null
@@ -128,7 +134,7 @@ public class Types {
         }
 
     };
-    
+
     public static boolean isPrimitive(Type type) {
     	return type == BOOLEAN || type == BYTE || type == CHARACTER || type == SHORT ||
     			type == INTEGER || type == LONG || type == FLOAT || type == DOUBLE || type == STRING;
@@ -152,11 +158,13 @@ public class Types {
      * Get the concrete type pointed to by a chain of type meta-variables.
      */
     public static Type canonical(Type type) {
-        while(type instanceof TMetaVar) {
+        if(type instanceof TMetaVar) {
             TMetaVar metaVar = (TMetaVar)type;
             type = metaVar.ref;
             if(type == null)
                 return metaVar;
+            else
+                return metaVar.ref = canonical(type);
         }
         return type;
     }
@@ -552,7 +560,15 @@ public class Types {
             parameters.add(Types.canonical(apply.parameter));
             type = canonical(apply.function);
         }
-        return new MultiApply(type, parameters.toArray(new Type[parameters.size()]));
+        Type[] parametersArray;
+        if(parameters.isEmpty())
+            parametersArray = Type.EMPTY_ARRAY;
+        else {
+            parametersArray = new Type[parameters.size()];
+            for(int i=0,j=parametersArray.length-1;i<parametersArray.length;++i,--j)
+                parametersArray[i] = parameters.get(j);
+        }
+        return new MultiApply(type, parametersArray);
     }
     
     public static Type unifyApply(TCon func, Type type) throws MatchException {
@@ -627,7 +643,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)
@@ -677,6 +738,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);
@@ -1005,6 +1083,15 @@ public class Types {
         return result;
     }
     
+    public static TPred[] replace(TPred[] types, TVar[] from, Type[] to) {
+        if(types.length == 0)
+            return TPred.EMPTY_ARRAY;
+        TPred[] result = new TPred[types.length];
+        for(int i=0;i<types.length;++i)
+            result[i] = (TPred)types[i].replace(from, to);
+        return result;
+    }
+    
     public static <T extends Type> Type[] replace(Type[] types, THashMap<TVar, T> map) {
         if(types.length == 0)
             return Type.EMPTY_ARRAY;
@@ -1022,6 +1109,14 @@ public class Types {
         else
             return new TUnion(effects);
     }
+    
+    public static Type union(Type effect1, Type effect2) {
+        return new TUnion(effect1, effect2);
+    }
+    
+    public static Type union(Type effect1, Type effect2, Type effect3) {
+        return new TUnion(effect1, effect2, effect3);
+    }
 
     public static Type union(List<Type> effects) {
         if(effects.size() == 0)
@@ -1092,17 +1187,9 @@ public class Types {
         return parseType(new TypeElaborationContext(environment), text);
     }
 
-    public static Type parseType(ITypeEnvironment environment, THashMap<String, TVar> localTypeVars, String text) throws SCLTypeParseException {
-        return parseType(new TypeElaborationContext(localTypeVars, environment), text);
-    }
-
     public static Type parseType(String text) throws SCLTypeParseException {
         return parseType(new TypeElaborationContext(DUMMY_TYPE_ENVIRONMENT), text);
     }
-
-    public static Type parseType(THashMap<String, TVar> localTypeVars, String text) throws SCLTypeParseException {
-        return parseType(new TypeElaborationContext(localTypeVars, DUMMY_TYPE_ENVIRONMENT), text);
-    }
     
     private static Type parseType(TypeElaborationContext context, String text) throws SCLTypeParseException {
         SCLParserImpl parser = new SCLParserImpl(new StringReader(text));