From f701a0be40598585cc1aec1ecf34e3fdd5690e81 Mon Sep 17 00:00:00 2001
From: Griffin Smith <root@gws.fyi>
Date: Mon, 23 Dec 2019 14:12:32 -0500
Subject: 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.
---
 test/Xanthous/Data/EntityMapSpec.hs | 22 +++++++++++++++++++---
 1 file changed, 19 insertions(+), 3 deletions(-)

(limited to 'test/Xanthous/Data/EntityMapSpec.hs')

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