add Compatible typeclass

1 files changed, 24 insertions, 17 deletions

diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs
index 03c41d6..3c48c4e 100644
--- a/test/WorldTypesTest.hs
+++ b/test/WorldTypesTest.hs
@@ -5,6 +5,7 @@ import Test.Tasty
 import Test.Tasty.HUnit
 import World.Types
   ( Merge (..)
+  , Compatible (..)
   , Pos
   , LatticeProposal (..)
   , AgentProposal (..)
@@ -17,9 +18,9 @@ suite = testGroup "world types tests" $
   [ latticePropTests
   ]
 
-newtype MockMerge = MockMerge Int
+newtype MockMerge = MockMerge Int deriving (Show, Eq)
 instance Merge MockMerge where
-  mergeCompatible (MockMerge x) (MockMerge y) = x == y
+  mergable (MockMerge x) (MockMerge y) = x == y
   merge x _ = x
   merge _ _ = error "incompatible merge!"
 
@@ -28,44 +29,50 @@ latticePropTests = testGroup "lattice proposal tests" $
   [ testCase "lattice proposals correctly detect mergability" $
     do
       -- disjoint positions
-      True @=? mergeCompatible
+      True @=? compatible 
         (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 1) Nothing Nothing Nothing)
-      True @=? mergeCompatible
-        (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge)
-        (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      True @=? mergeCompatible
+      True @=? compatible
         (LatticeProposal (1, 0) (Just 4) (Just 5) Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) (Just 5) (Just 5) Nothing)
       -- merge from
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) (Just 4) Nothing Nothing)
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      False @=? mergeCompatible
+      False @=? mergable
         (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) (Just 5) Nothing Nothing)
       -- merge to
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing (Just 4) Nothing)
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      False @=? mergeCompatible
+      False @=? mergable
         (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing (Just 2) Nothing)
       -- merge flags
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing Nothing Nothing)
-      True @=? mergeCompatible
+      True @=? mergable
         (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4))
-      False @=? mergeCompatible
+      False @=? mergable
         (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge)
         (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 5))
+
+
+  , testCase "merge lattice proposals" $
+    do
+      LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) @?= merge
+        (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge)
+        (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4))
+      LatticeProposal (0, 0) (Just 2) (Just 4) (Just $ MockMerge 4) @?= merge
+        (LatticeProposal (0, 0) (Just 2) Nothing Nothing)
+        (LatticeProposal (0, 0) Nothing (Just 4) (Just $ MockMerge 4))
   ]
-