about summary refs log tree commit diff
path: root/test/Xanthous/Data/EntityMapSpec.hs
diff options
context:
space:
mode:
authorGriffin Smith <root@gws.fyi>2019-12-23T19·12-0500
committerGriffin Smith <root@gws.fyi>2019-12-23T22·22-0500
commitf701a0be40598585cc1aec1ecf34e3fdd5690e81 (patch)
tree687ec8f9bc1cb6c4ad25271b289f19ae70639499 /test/Xanthous/Data/EntityMapSpec.hs
parent052bc8455a99e7f1a90b6c9354e54cff10de02cc (diff)
Preserve entityIDs in atPosition's setter
Make the setter for the atPosition lens preserve entityIDs for
already-existing entities at the position, so that when we plop
something in the same tile as the character the character's entity ID
doesn't disappear.
Diffstat (limited to 'test/Xanthous/Data/EntityMapSpec.hs')
-rw-r--r--test/Xanthous/Data/EntityMapSpec.hs22
1 files changed, 19 insertions, 3 deletions
diff --git a/test/Xanthous/Data/EntityMapSpec.hs b/test/Xanthous/Data/EntityMapSpec.hs
index 8317f5f51f8b..7c5cad019616 100644
--- a/test/Xanthous/Data/EntityMapSpec.hs
+++ b/test/Xanthous/Data/EntityMapSpec.hs
@@ -3,11 +3,11 @@
 module Xanthous.Data.EntityMapSpec where
 --------------------------------------------------------------------------------
 import           Test.Prelude
-import           Control.Lens.Properties
 --------------------------------------------------------------------------------
 import qualified Data.Aeson as JSON
 --------------------------------------------------------------------------------
 import           Xanthous.Data.EntityMap
+import           Xanthous.Data (Positioned(..))
 --------------------------------------------------------------------------------
 
 main :: IO ()
@@ -47,7 +47,23 @@ test = localOption (QuickCheckTests 20)
         in toEIDsAndPositioned em' === toEIDsAndPositioned em
     ]
 
-  , testGroup "atPosition"
-    [ testProperty "lens laws" $ \pos -> isLens $ atPosition @Int pos
+  , localOption (QuickCheckTests 50)
+  $ testGroup "atPosition"
+    [ testProperty "setget" $ \pos (em :: EntityMap Int) es ->
+        view (atPosition pos) (set (atPosition pos) es em) === es
+    , testProperty "getset" $ \pos (em :: EntityMap Int) ->
+        set (atPosition pos) (view (atPosition pos) em) em === em
+    , testProperty "setset" $ \pos (em :: EntityMap Int) es ->
+        (set (atPosition pos) es . set (atPosition pos) es) em
+        ===
+        set (atPosition pos) es em
+      -- testProperty "lens laws" $ \pos -> isLens $ atPosition @Int pos
+    , testProperty "preserves IDs" $ \(em :: EntityMap Int) e1 e2 p ->
+        let (eid, em') = insertAtReturningID p e1 em
+            em'' = em' & atPosition p %~ (e2 <|)
+        in
+          counterexample ("em': " <> show em')
+          . counterexample ("em'': " <> show em'')
+          $ em'' ^. at eid === Just (Positioned p e1)
     ]
   ]