tvl-depot/users/aspen/xanthous/test/Xanthous/Data/EntityMapSpec.hs
Aspen Smith 82ecd61f5c chore(users): grfn -> aspen
Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>
2024-02-14 19:37:41 +00:00

69 lines
3 KiB
Haskell

{-# LANGUAGE ApplicativeDo #-}
--------------------------------------------------------------------------------
module Xanthous.Data.EntityMapSpec where
--------------------------------------------------------------------------------
import Test.Prelude
--------------------------------------------------------------------------------
import qualified Data.Aeson as JSON
--------------------------------------------------------------------------------
import Xanthous.Data.EntityMap
import Xanthous.Data (Positioned(..))
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain test
test :: TestTree
test = localOption (QuickCheckTests 20)
$ testGroup "Xanthous.Data.EntityMap"
[ testBatch $ monoid @(EntityMap Int) mempty
, testGroup "Deduplicate"
[ testGroup "Semigroup laws"
[ testProperty "associative" $ \(a :: Deduplicate (EntityMap Int)) b c ->
a <> (b <> c) === (a <> b) <> c
]
]
, testGroup "Eq laws"
[ testProperty "reflexivity" $ \(em :: EntityMap Int) ->
em == em
, testProperty "symmetric" $ \(em :: EntityMap Int) em ->
(em == em) == (em == em)
, testProperty "transitive" $ \(em :: EntityMap Int) em em ->
if (em == em && em == em)
then (em == em)
else True
]
, testGroup "JSON encoding/decoding"
[ testProperty "round-trips" $ \(em :: EntityMap Int) ->
let em' = JSON.decode (JSON.encode em)
in counterexample (show (em' ^? _Just . lastID, em ^. lastID
, em' ^? _Just . byID == em ^. byID . re _Just
, em' ^? _Just . byPosition == em ^. byPosition . re _Just
, em' ^? _Just . _EntityMap == em ^. _EntityMap . re _Just
))
$ em' === Just em
, testProperty "Preserves IDs" $ \(em :: EntityMap Int) ->
let Just em' = JSON.decode $ JSON.encode em
in toEIDsAndPositioned em' === toEIDsAndPositioned em
]
, 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)
]
]