From: Hannu Niemistö Date: Fri, 1 Mar 2019 12:46:09 +0000 (+0000) Subject: Merge "Expose CommandSession in SCL" X-Git-Tag: v1.43.0~136^2~183 X-Git-Url: https://gerrit.simantics.org/r/gitweb?p=simantics%2Fplatform.git;a=commitdiff_plain;h=08a43c849e0bed256394e3861326af9ce26a9917;hp=718558937433af8710e2e32402e3557eb67e3f43 Merge "Expose CommandSession in SCL" --- diff --git a/bundles/org.simantics.modeling/scl/Simantics/Subscription.scl b/bundles/org.simantics.modeling/scl/Simantics/Subscription.scl index 01bc3f058..2672067c4 100644 --- a/bundles/org.simantics.modeling/scl/Simantics/Subscription.scl +++ b/bundles/org.simantics.modeling/scl/Simantics/Subscription.scl @@ -163,7 +163,7 @@ Example: create a subscription of module PO01 attribute PO11_PRESSURE to the def #430121 """ -addSubscription :: Variable -> Subscription +addSubscription :: Variable -> Subscription addSubscription variable = do model = modelOfVariable variable default = defaultSubscriptionFolder model diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/chr/CHRQuery.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/chr/CHRQuery.java index 7bee6eae0..6b01d9953 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/chr/CHRQuery.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/chr/CHRQuery.java @@ -10,8 +10,11 @@ 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.Expression; +import org.simantics.scl.compiler.elaboration.expressions.ExpressionVisitor; import org.simantics.scl.compiler.elaboration.expressions.Variable; import org.simantics.scl.compiler.elaboration.expressions.printing.ExpressionToStringVisitor; +import org.simantics.scl.compiler.elaboration.expressions.visitors.ForVariablesUsesVisitor; +import org.simantics.scl.compiler.elaboration.expressions.visitors.StandardExpressionVisitor; import org.simantics.scl.compiler.errors.Locations; import org.simantics.scl.compiler.internal.parsing.Symbol; @@ -92,4 +95,16 @@ public class CHRQuery extends Symbol { newLiterals[i] = literals[i].replace(context); return new CHRQuery(location, newLiterals); } + + public void accept(ExpressionVisitor visitor) { + for(CHRLiteral literal : literals) { + if(literal == null || literal.parameters == null) + continue; // FIXME why this happens? + for(Expression parameter : literal.parameters) { + if(parameter == null) + continue; // FIXME why this happens? + parameter.accept(visitor); + } + } + } } diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/chr/CHRRule.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/chr/CHRRule.java index 78224ebb0..e698d72c6 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/chr/CHRRule.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/chr/CHRRule.java @@ -1,6 +1,7 @@ package org.simantics.scl.compiler.elaboration.chr; import java.util.ArrayList; +import java.util.HashMap; import org.simantics.scl.compiler.compilation.CompilationContext; import org.simantics.scl.compiler.elaboration.chr.plan.CHRSearchPlan; @@ -9,9 +10,13 @@ import org.simantics.scl.compiler.elaboration.chr.relations.CHRConstraint; 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.EAsPattern; import org.simantics.scl.compiler.elaboration.expressions.EVariable; +import org.simantics.scl.compiler.elaboration.expressions.Expression; +import org.simantics.scl.compiler.elaboration.expressions.ExpressionVisitor; import org.simantics.scl.compiler.elaboration.expressions.Variable; import org.simantics.scl.compiler.elaboration.expressions.printing.ExpressionToStringVisitor; +import org.simantics.scl.compiler.elaboration.expressions.visitors.StandardExpressionVisitor; import org.simantics.scl.compiler.errors.Locations; import org.simantics.scl.compiler.internal.parsing.Symbol; import org.simantics.scl.compiler.types.Types; @@ -54,6 +59,52 @@ public class CHRRule extends Symbol { context.disallowNewExistentials(); body.resolve(context); existentialVariables = context.popExistentialFrame(); + + warnForExistentialsUsedOnlyOnce(context); + } + + private static final Object NEVER_USED = new Object(); + + private void warnForExistentialsUsedOnlyOnce(TranslationContext context) { + // Initialize the hash map + HashMap usageCount = new HashMap<>(existentialVariables.length); + for(Variable var : existentialVariables) + if(!var.getName().equals("_")) + usageCount.put(var, NEVER_USED); + + // Collect variable uses + ExpressionVisitor visitor = new StandardExpressionVisitor() { + private void handle(Expression expression, Variable variable) { + Object object = usageCount.remove(variable); + if(object == NEVER_USED) + usageCount.put(variable, expression); + } + @Override + public void visit(EVariable expression) { + if(expression.variable != null) + handle(expression, expression.variable); + } + @Override + public void visit(EAsPattern expression) { + expression.pattern.accept(this); + handle(expression, expression.var); + } + }; + head.accept(visitor); + body.accept(visitor); + + // Report as warnings + usageCount.forEach((variable, expression_) -> { + if(!(expression_ instanceof Expression)) + return; // Should never happen + Expression expression = (Expression)expression_; + if(context.isExpandedFromWildcard(expression)) + return; + + context.getErrorLog().logWarning(expression.location, + "Existential variable " + variable.getName() + " is referred only once. Replace by _ if this is a wildcard."); + }); + } public void checkType(TypingContext context) { diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TranslationContext.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TranslationContext.java index d8346f41f..e0c256599 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TranslationContext.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TranslationContext.java @@ -76,6 +76,8 @@ public class TranslationContext extends TypeTranslationContext implements Enviro TIntArrayList chrConstraintFrames = new TIntArrayList(); ArrayList chrConstraintEntries = new ArrayList(); + private THashSet expandedFromWildcard; + public CHRRuleset currentRuleset; public ModuleDebugInfo moduleDebugInfo; @@ -141,7 +143,7 @@ public class TranslationContext extends TypeTranslationContext implements Enviro variable = new Variable(name); variables.put(name, variable); existentialFrame.variables.add(name); - return new EVariable(variable); + return new EVariable(location, variable); } case '_': { if(name.length()==1) { @@ -583,7 +585,29 @@ public class TranslationContext extends TypeTranslationContext implements Enviro return Environments.getRuleset(environment, name); } + /** + * Tells that new existential variables are no longer allowed in this context. + */ public void disallowNewExistentials() { getCurrentExistentialFrame().disallowNewExistentials = true; } + + /** + * Marks that the expression is a result of expanding .. wildcard pattern in records. + */ + public void addExpandedFromWildcard(Expression expression) { + if(expandedFromWildcard == null) + expandedFromWildcard = new THashSet<>(); + expandedFromWildcard.add(expression); + } + + /** + * Asks if the expression is a result of expanding .. wildcard pattern in records. + */ + public boolean isExpandedFromWildcard(Expression expression) { + if(expandedFromWildcard == null) + return false; + else + return expandedFromWildcard.contains(expression); + } } diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/ERecord.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/ERecord.java index 47ef205df..cb34d0fb3 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/ERecord.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/ERecord.java @@ -150,7 +150,9 @@ public class ERecord extends ASTExpression { String variableName = fieldNames[i]; if(chrLiteral) variableName = "?" + variableName; - parameters[i] = new EVar(wildcardField.location, variableName); + EVar expandedVar = new EVar(wildcardField.location, variableName); + parameters[i] = expandedVar; + context.addExpandedFromWildcard(expandedVar); } } if(!recordMap.isEmpty()) { diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EVar.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EVar.java index d78fa8565..2e4809a0c 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EVar.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EVar.java @@ -49,7 +49,10 @@ public class EVar extends ASTExpression { @Override public Expression resolve(TranslationContext context) { - return context.resolveVariable(location, name); + Expression resolved = context.resolveVariable(location, name); + if(context.isExpandedFromWildcard(this)) + context.addExpandedFromWildcard(resolved); + return resolved; } @Override @@ -59,7 +62,10 @@ public class EVar extends ASTExpression { @Override public Expression resolveAsPattern(TranslationContext context) { - return context.resolvePattern(this); + Expression resolved = context.resolvePattern(this); + if(context.isExpandedFromWildcard(this)) + context.addExpandedFromWildcard(resolved); + return resolved; } @Override diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/VariableProcedure.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/VariableProcedure.java index 44e9b6ae7..af50692fa 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/VariableProcedure.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/VariableProcedure.java @@ -1,5 +1,6 @@ package org.simantics.scl.compiler.elaboration.expressions; +@FunctionalInterface public interface VariableProcedure { void execute(long location, Variable variable); } diff --git a/bundles/org.simantics.scl.runtime/scl/Iterator.scl b/bundles/org.simantics.scl.runtime/scl/Iterator.scl index 19e51a0d5..b98e14f42 100644 --- a/bundles/org.simantics.scl.runtime/scl/Iterator.scl +++ b/bundles/org.simantics.scl.runtime/scl/Iterator.scl @@ -1,3 +1,5 @@ +import "JavaBuiltin" as Java + importJava "java.util.Iterator" where data T a @@ -16,6 +18,17 @@ iter f it = loop () loop () else () +@inline +iterI :: (Integer -> a -> b) -> T a -> () +iterI f it = loop 0 + where + loop i = + if hasNext it + then do + f i (next it) + loop (Java.iadd i 1) + else () + @inline iterB :: (a -> Boolean) -> T a -> Boolean iterB f it = loop () diff --git a/bundles/org.simantics.scl.runtime/scl/Prelude.scl b/bundles/org.simantics.scl.runtime/scl/Prelude.scl index 80b4d0ad7..c175f95a3 100644 --- a/bundles/org.simantics.scl.runtime/scl/Prelude.scl +++ b/bundles/org.simantics.scl.runtime/scl/Prelude.scl @@ -963,6 +963,9 @@ A class of monads with zero element satisfying """ class (Monad m) => MonadZero m where mzero :: m a + mfilter :: (a -> Boolean) -> m a -> m a + + mfilter p m = m >>= (\x -> if p x then return x else mzero) "Injects a boolean test to a type beloning to `MonadZero`." guard :: MonadZero m => Boolean -> m () @@ -1105,7 +1108,21 @@ instance MonadE (Either a) where instance MonadE [] where bindE l f = concatMap f l + +/// MZeroE /// + +class (MonadE m, MonadZero m) => MonadZeroE m where + filter :: (a -> Boolean) -> m a -> m a + + filter p m = m `bindE` (\x -> if p x then return x else mzero) +instance MonadZeroE [] where + filter = filterList + +instance MonadZeroE Maybe where + filter p (Just x) | not (p x) = Nothing + filter _ m = m + /// Category /// "Identity function." @@ -1841,10 +1858,10 @@ foldr1 f l = loop (l!(len-1)) (len-2) `filter pred lst` returns those elements of `lst` that the predicate `pred` accepts. For example filter (> 3) [1, 2, 3, 4, 5, 6] = [4, 5, 6] -""" +""" @inline -filter :: (a -> Boolean) -> [a] -> [a] -filter p l = build (\empty cons -> foldl (\cur x -> if p x then cons cur x else cur) empty l) +filterList :: (a -> Boolean) -> [a] -> [a] +filterList p l = build (\empty cons -> foldl (\cur x -> if p x then cons cur x else cur) empty l) """ Takes those elements of the input list that match `(Just x)` and adds the contents to the resulting list. For example, diff --git a/bundles/org.simantics.scl.runtime/scl/Set.scl b/bundles/org.simantics.scl.runtime/scl/Set.scl index 2bf2911c5..34033d91e 100644 --- a/bundles/org.simantics.scl.runtime/scl/Set.scl +++ b/bundles/org.simantics.scl.runtime/scl/Set.scl @@ -11,13 +11,31 @@ importJava "java.util.Set" where iterator :: T a -> Iterator.T a @inline -iter :: (a -> ()) -> T a -> () +iter :: (a -> b) -> T a -> () iter f s = runProc (Iterator.iter f (iterator s)) @inline iterB :: (a -> Boolean) -> T a -> Boolean iterB f s = runProc (Iterator.iterB f (iterator s)) +@inline +iterI :: (Integer -> a -> b) -> T a -> () +iterI f s = runProc (Iterator.iterI f (iterator s)) + @inline fold :: (a -> b -> a) -> a -> T b -> a fold f init s = runProc (Iterator.fold f init (iterator s)) + +importJava "java.util.Collections" where + singleton :: a -> T a + + @JavaName emptySet + empty :: T a + +importJava "gnu.trove.set.hash.THashSet" where + @JavaName "" + fromList :: [a] -> T a + +importJava "java.util.ArrayList" where + @JavaName "" + toList :: T a -> [a] diff --git a/bundles/org.simantics.scl.runtime/scl/SetClasses.scl b/bundles/org.simantics.scl.runtime/scl/SetClasses.scl new file mode 100644 index 000000000..8c3d1e6a8 --- /dev/null +++ b/bundles/org.simantics.scl.runtime/scl/SetClasses.scl @@ -0,0 +1,61 @@ +import "Prelude" +import "MSet" as MSet +import "Set" as Set + +instance Functor Set.T where + fmap = map + +instance FunctorE Set.T where + map f set = runProc do + result = MSet.create () + Set.iter (\x -> MSet.add result $ f x) set + MSet.freeze result + + iter = Set.iter + iterI = Set.iterI + +instance Monad Set.T where + return = Set.singleton + (>>=) = bindE + +@private +importJava "java.util.Set" where + @JavaName addAll + addAll' :: MSet.T a -> Set.T a -> Boolean + +instance MonadE Set.T where + set `bindE` f = runProc do + result = MSet.create () + Set.iter (\x -> addAll' result $ f x) set + MSet.freeze result + +instance MonadZero Set.T where + mzero = Set.empty + +instance MonadZeroE Set.T where + filter p set = runProc do + result = MSet.create () + Set.iter (\x -> + if p x + then ignore $ MSet.add result x + else () + ) set + MSet.freeze result + +instance (Show a) => Show (Set.T a) where + sb <+ set = do + sb << "{" + Set.iterI (\i x -> (if i > 0 then sb << ", " else sb) <+ x) set + sb << "}" + +instance Additive (Set.T a) where + zero = Set.empty + a + b = runProc do + result = MSet.create () + Set.iter (MSet.add result) a + Set.iter (MSet.add result) b + MSet.freeze result + sum sets = runProc do + result = MSet.create () + iter (Set.iter (MSet.add result)) sets + MSet.freeze result \ No newline at end of file diff --git a/bundles/org.simantics.scl.runtime/scl/SetUtils.scl b/bundles/org.simantics.scl.runtime/scl/SetUtils.scl deleted file mode 100644 index 00fa75215..000000000 --- a/bundles/org.simantics.scl.runtime/scl/SetUtils.scl +++ /dev/null @@ -1,13 +0,0 @@ -import "Prelude" -import "Set" as Set -import "MSet" as MSet -import "MList" as MList - -fromList :: [a] -> Set.T a -fromList l = runProc (MSet.freeze $ MSet.fromList l) - -toList :: Set.T a -> [a] -toList s = runProc do - result = MList.createC (Set.size s) - Set.iter (MList.add result) s - MList.freeze result \ No newline at end of file diff --git a/bundles/org.simantics.scl.runtime/scl/StandardLibrary.scl b/bundles/org.simantics.scl.runtime/scl/StandardLibrary.scl index 7234b70be..e774f9746 100644 --- a/bundles/org.simantics.scl.runtime/scl/StandardLibrary.scl +++ b/bundles/org.simantics.scl.runtime/scl/StandardLibrary.scl @@ -10,7 +10,7 @@ include "Lazy" as Lazy include "File" as File include "Serialization" as Serialization include "Set" as Set -include "SetUtils" as Set +include "SetClasses" //include "Map" as Map include "MMap" as MMap include "MSet" as MSet diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/CHR4.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/CHR4.scl index dc0714973..90b82e79a 100644 --- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/CHR4.scl +++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/CHR4.scl @@ -3,7 +3,9 @@ main = () when ?x <- ?y then True -- +3:10-3:12: Existential variable ?x is referred only once. Replace by _ if this is a wildcard. 3:10-3:18: Cannot solve the query. +3:16-3:18: Existential variable ?y is referred only once. Replace by _ if this is a wildcard. -- import "Prelude" diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/CHR8.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/CHR8.scl index dd915ebb5..6929a0b92 100644 --- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/CHR8.scl +++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/CHR8.scl @@ -5,4 +5,5 @@ main = () where X ?x => Y ?y -- +6:7-6:9: Existential variable ?x is referred only once. Replace by _ if this is a wildcard. 6:15-6:17: New existential variables can be defined only in queries. \ No newline at end of file