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.

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)
     ]
   ]