From: Hannu Niemistö <hannu.niemisto@semantum.fi>
Date: Fri, 1 Mar 2019 11:04:14 +0000 (+0200)
Subject: Implemented many type class instances for Set.T
X-Git-Tag: v1.43.0~136^2~185^2
X-Git-Url: https://gerrit.simantics.org/r/gitweb?a=commitdiff_plain;h=refs%2Fchanges%2F41%2F2741%2F2;p=simantics%2Fplatform.git

Implemented many type class instances for Set.T

Change-Id: I6190579fb7715ebfc5b165941cb33c6d27e84148
---

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 -> <e> b) -> T a -> <Proc,e> ()
+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 -> <e> Boolean) -> T a -> <Proc,e> 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 -> <e> Boolean) -> m a -> <e> 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 -> <e> Boolean) -> [a] -> <e> [a]
-filter p l = build (\empty cons -> foldl (\cur x -> if p x then cons cur x else cur) empty l)
+filterList :: (a -> <e> Boolean) -> [a] -> <e> [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 -> <e> ()) -> T a -> <e> ()
+iter :: (a -> <e> b) -> T a -> <e> ()
 iter f s = runProc (Iterator.iter f (iterator s))
 
 @inline
 iterB :: (a -> <e> Boolean) -> T a -> <e> Boolean
 iterB f s = runProc (Iterator.iterB f (iterator s))
 
+@inline
+iterI :: (Integer -> a -> <e> b) -> T a -> <e> ()
+iterI f s = runProc (Iterator.iterI f (iterator s))
+
 @inline
 fold :: (a -> b  -> <e> a) -> a -> T b -> <e> 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 "<init>"
+    fromList :: [a] -> T a
+
+importJava "java.util.ArrayList" where
+    @JavaName "<init>"
+    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 -> <Proc> 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