Fix an injectivity issue with saving the game
Fix an injectivity issue with JSON-encoding the entity map that was causing the game saving to not properly round-trip. As part of this, there's a refactor to the internals of the entity map to use sets instead of vectors, which should also get us a nice perf boost.
This commit is contained in:
parent
310ea90985
commit
97a5c61f28
15 changed files with 90 additions and 34 deletions
|
@ -41,6 +41,7 @@ dependencies:
|
||||||
- MonadRandom
|
- MonadRandom
|
||||||
- mtl
|
- mtl
|
||||||
- optparse-applicative
|
- optparse-applicative
|
||||||
|
- parallel
|
||||||
- random
|
- random
|
||||||
- random-fu
|
- random-fu
|
||||||
- random-extras
|
- random-extras
|
||||||
|
@ -97,6 +98,7 @@ executable:
|
||||||
- -threaded
|
- -threaded
|
||||||
- -rtsopts
|
- -rtsopts
|
||||||
- -with-rtsopts=-N
|
- -with-rtsopts=-N
|
||||||
|
- -O2
|
||||||
|
|
||||||
tests:
|
tests:
|
||||||
test:
|
test:
|
||||||
|
@ -106,6 +108,7 @@ tests:
|
||||||
- -threaded
|
- -threaded
|
||||||
- -rtsopts
|
- -rtsopts
|
||||||
- -with-rtsopts=-N
|
- -with-rtsopts=-N
|
||||||
|
- -O0
|
||||||
dependencies:
|
dependencies:
|
||||||
- xanthous
|
- xanthous
|
||||||
- tasty
|
- tasty
|
||||||
|
|
|
@ -115,7 +115,7 @@ type Position = Position' Int
|
||||||
|
|
||||||
instance Arbitrary a => Arbitrary (Position' a) where
|
instance Arbitrary a => Arbitrary (Position' a) where
|
||||||
arbitrary = genericArbitrary
|
arbitrary = genericArbitrary
|
||||||
shrink = genericShrink
|
shrink (Position px py) = Position <$> shrink px <*> shrink py
|
||||||
|
|
||||||
|
|
||||||
instance Num a => Semigroup (Position' a) where
|
instance Num a => Semigroup (Position' a) where
|
||||||
|
|
|
@ -30,7 +30,7 @@ data EntityChar = EntityChar
|
||||||
{ _char :: Char
|
{ _char :: Char
|
||||||
, _style :: Vty.Attr
|
, _style :: Vty.Attr
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Generic)
|
deriving stock (Show, Eq, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving Arbitrary via GenericArbitrary EntityChar
|
deriving Arbitrary via GenericArbitrary EntityChar
|
||||||
makeFieldsNoPrefix ''EntityChar
|
makeFieldsNoPrefix ''EntityChar
|
||||||
|
|
|
@ -27,6 +27,7 @@ module Xanthous.Data.EntityMap
|
||||||
-- * debug
|
-- * debug
|
||||||
, byID
|
, byID
|
||||||
, byPosition
|
, byPosition
|
||||||
|
, lastID
|
||||||
|
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -46,26 +47,28 @@ import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function)
|
||||||
import Test.QuickCheck.Checkers (EqProp)
|
import Test.QuickCheck.Checkers (EqProp)
|
||||||
import Test.QuickCheck.Instances.UnorderedContainers ()
|
import Test.QuickCheck.Instances.UnorderedContainers ()
|
||||||
import Test.QuickCheck.Instances.Vector ()
|
import Test.QuickCheck.Instances.Vector ()
|
||||||
|
import Text.Show (showString, showParen)
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
type EntityID = Word32
|
type EntityID = Word32
|
||||||
type NonNullVector a = NonNull (Vector a)
|
type NonNullSet a = NonNull (Set a)
|
||||||
|
|
||||||
data EntityMap a where
|
data EntityMap a where
|
||||||
EntityMap ::
|
EntityMap ::
|
||||||
{ _byPosition :: Map Position (NonNullVector EntityID)
|
{ _byPosition :: Map Position (NonNullSet EntityID)
|
||||||
, _byID :: HashMap EntityID (Positioned a)
|
, _byID :: HashMap EntityID (Positioned a)
|
||||||
, _lastID :: EntityID
|
, _lastID :: EntityID
|
||||||
} -> EntityMap a
|
} -> EntityMap a
|
||||||
deriving stock (Functor, Foldable, Traversable, Generic)
|
deriving stock (Functor, Foldable, Traversable, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving via (EqEqProp (EntityMap a)) instance Eq a => EqProp (EntityMap a)
|
deriving via (EqEqProp (EntityMap a)) instance (Eq a, Ord a) => EqProp (EntityMap a)
|
||||||
makeLenses ''EntityMap
|
makeLenses ''EntityMap
|
||||||
|
|
||||||
instance ToJSON a => ToJSON (EntityMap a) where
|
instance ToJSON a => ToJSON (EntityMap a) where
|
||||||
toJSON = toJSON . toEIDsAndPositioned
|
toJSON = toJSON . toEIDsAndPositioned
|
||||||
|
|
||||||
|
|
||||||
instance FromJSON a => FromJSON (EntityMap a) where
|
instance FromJSON a => FromJSON (EntityMap a) where
|
||||||
parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON
|
parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON
|
||||||
|
|
||||||
|
@ -73,14 +76,24 @@ byIDInvariantError :: forall a. a
|
||||||
byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition "
|
byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition "
|
||||||
<> "must point to entityIDs in byID"
|
<> "must point to entityIDs in byID"
|
||||||
|
|
||||||
instance Eq a => Eq (EntityMap a) where
|
instance (Ord a, Eq a) => Eq (EntityMap a) where
|
||||||
em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap
|
-- em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap
|
||||||
|
(==) = (==) `on` view (_EntityMap . to sort)
|
||||||
|
|
||||||
|
deriving stock instance (Ord a) => Ord (EntityMap a)
|
||||||
|
|
||||||
instance Show a => Show (EntityMap a) where
|
instance Show a => Show (EntityMap a) where
|
||||||
show em = "_EntityMap # " <> show (em ^. _EntityMap)
|
showsPrec pr em
|
||||||
|
= showParen (pr > 10)
|
||||||
|
$ showString
|
||||||
|
. ("fromEIDsAndPositioned " <>)
|
||||||
|
. show
|
||||||
|
. toEIDsAndPositioned
|
||||||
|
$ em
|
||||||
|
|
||||||
instance Arbitrary a => Arbitrary (EntityMap a) where
|
instance Arbitrary a => Arbitrary (EntityMap a) where
|
||||||
arbitrary = review _EntityMap <$> arbitrary
|
arbitrary = review _EntityMap <$> arbitrary
|
||||||
|
shrink em = review _EntityMap <$> shrink (em ^. _EntityMap)
|
||||||
|
|
||||||
type instance Index (EntityMap a) = EntityID
|
type instance Index (EntityMap a) = EntityID
|
||||||
type instance IxValue (EntityMap a) = (Positioned a)
|
type instance IxValue (EntityMap a) = (Positioned a)
|
||||||
|
@ -102,10 +115,10 @@ instance At (EntityMap a) where
|
||||||
)
|
)
|
||||||
& byID . at eid ?~ pe
|
& byID . at eid ?~ pe
|
||||||
& byPosition . at pos %~ \case
|
& byPosition . at pos %~ \case
|
||||||
Nothing -> Just $ ncons eid mempty
|
Nothing -> Just $ opoint eid
|
||||||
Just es -> Just $ eid <| es
|
Just es -> Just $ ninsertSet eid es
|
||||||
removeEIDAtPos pos =
|
removeEIDAtPos pos =
|
||||||
byPosition . at pos %~ (>>= fromNullable . nfilter (/= eid))
|
byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid)
|
||||||
|
|
||||||
instance Semigroup (EntityMap a) where
|
instance Semigroup (EntityMap a) where
|
||||||
em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁
|
em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁
|
||||||
|
@ -137,8 +150,8 @@ instance Semigroup (Deduplicate a) where
|
||||||
_byPosition = mempty &~ do
|
_byPosition = mempty &~ do
|
||||||
ifor_ _byID $ \eid (Positioned pos _) ->
|
ifor_ _byID $ \eid (Positioned pos _) ->
|
||||||
at pos %= \case
|
at pos %= \case
|
||||||
Just eids -> Just $ eid <| eids
|
Just eids -> Just $ ninsertSet eid eids
|
||||||
Nothing -> Just $ ncons eid mempty
|
Nothing -> Just $ opoint eid
|
||||||
_lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
|
_lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
|
||||||
in Deduplicate EntityMap{..}
|
in Deduplicate EntityMap{..}
|
||||||
|
|
||||||
|
@ -164,8 +177,8 @@ insertAtReturningID pos e em =
|
||||||
in em'
|
in em'
|
||||||
& byID . at eid ?~ Positioned pos e
|
& byID . at eid ?~ Positioned pos e
|
||||||
& byPosition . at pos %~ \case
|
& byPosition . at pos %~ \case
|
||||||
Nothing -> Just $ ncons eid mempty
|
Nothing -> Just $ opoint eid
|
||||||
Just es -> Just $ eid <| es
|
Just es -> Just $ ninsertSet eid es
|
||||||
& (eid, )
|
& (eid, )
|
||||||
|
|
||||||
insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a
|
insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a
|
||||||
|
@ -176,7 +189,8 @@ atPosition pos = lens getter setter
|
||||||
where
|
where
|
||||||
getter em =
|
getter em =
|
||||||
let eids :: Vector EntityID
|
let eids :: Vector EntityID
|
||||||
eids = maybe mempty toNullable $ em ^. byPosition . at pos
|
eids = maybe mempty (toVector . toNullable)
|
||||||
|
$ em ^. byPosition . at pos
|
||||||
in getEIDAssume em <$> eids
|
in getEIDAssume em <$> eids
|
||||||
setter em Empty = em & byPosition . at pos .~ Nothing
|
setter em Empty = em & byPosition . at pos .~ Nothing
|
||||||
setter em entities = alaf Endo foldMap (insertAt pos) entities em
|
setter em entities = alaf Endo foldMap (insertAt pos) entities em
|
||||||
|
@ -187,7 +201,8 @@ getEIDAssume em eid = fromMaybe byIDInvariantError
|
||||||
|
|
||||||
atPositionWithIDs :: Position -> EntityMap a -> Vector (EntityID, Positioned a)
|
atPositionWithIDs :: Position -> EntityMap a -> Vector (EntityID, Positioned a)
|
||||||
atPositionWithIDs pos em =
|
atPositionWithIDs pos em =
|
||||||
let eids = maybe mempty toNullable $ em ^. byPosition . at pos
|
let eids = maybe mempty (toVector . toNullable)
|
||||||
|
$ em ^. byPosition . at pos
|
||||||
in (id &&& Positioned pos . getEIDAssume em) <$> eids
|
in (id &&& Positioned pos . getEIDAssume em) <$> eids
|
||||||
|
|
||||||
fromEIDsAndPositioned
|
fromEIDsAndPositioned
|
||||||
|
@ -199,8 +214,8 @@ fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty
|
||||||
insert' (eid, pe@(Positioned pos _))
|
insert' (eid, pe@(Positioned pos _))
|
||||||
= (byID . at eid ?~ pe)
|
= (byID . at eid ?~ pe)
|
||||||
. (byPosition . at pos %~ \case
|
. (byPosition . at pos %~ \case
|
||||||
Just eids -> Just $ eid <| eids
|
Just eids -> Just $ ninsertSet eid eids
|
||||||
Nothing -> Just $ ncons eid mempty
|
Nothing -> Just $ opoint eid
|
||||||
)
|
)
|
||||||
newLastID em = em & lastID
|
newLastID em = em & lastID
|
||||||
.~ fromMaybe 1
|
.~ fromMaybe 1
|
||||||
|
|
|
@ -39,7 +39,7 @@ data Character = Character
|
||||||
, _characterHitpoints' :: !Double
|
, _characterHitpoints' :: !Double
|
||||||
, _speed :: TicksPerTile
|
, _speed :: TicksPerTile
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Generic)
|
deriving stock (Show, Eq, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving (ToJSON, FromJSON)
|
deriving (ToJSON, FromJSON)
|
||||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||||
|
|
|
@ -47,7 +47,7 @@ data Destination = Destination
|
||||||
-- When this value reaches >= 1, the creature has reached their destination
|
-- When this value reaches >= 1, the creature has reached their destination
|
||||||
, _destinationProgress :: !Tiles
|
, _destinationProgress :: !Tiles
|
||||||
}
|
}
|
||||||
deriving stock (Eq, Show, Generic)
|
deriving stock (Eq, Show, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving (ToJSON, FromJSON)
|
deriving (ToJSON, FromJSON)
|
||||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||||
|
@ -63,7 +63,7 @@ destinationFromPos _destinationPosition =
|
||||||
data Hippocampus = Hippocampus
|
data Hippocampus = Hippocampus
|
||||||
{ _destination :: !(Maybe Destination)
|
{ _destination :: !(Maybe Destination)
|
||||||
}
|
}
|
||||||
deriving stock (Eq, Show, Generic)
|
deriving stock (Eq, Show, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving (ToJSON, FromJSON)
|
deriving (ToJSON, FromJSON)
|
||||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||||
|
@ -81,7 +81,7 @@ data Creature = Creature
|
||||||
, _hitpoints :: !Hitpoints
|
, _hitpoints :: !Hitpoints
|
||||||
, _hippocampus :: !Hippocampus
|
, _hippocampus :: !Hippocampus
|
||||||
}
|
}
|
||||||
deriving stock (Eq, Show, Generic)
|
deriving stock (Eq, Show, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
|
deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
|
||||||
deriving (ToJSON, FromJSON)
|
deriving (ToJSON, FromJSON)
|
||||||
|
|
|
@ -21,7 +21,7 @@ import Xanthous.Game.State
|
||||||
data Item = Item
|
data Item = Item
|
||||||
{ _itemType :: ItemType
|
{ _itemType :: ItemType
|
||||||
}
|
}
|
||||||
deriving stock (Eq, Show, Generic)
|
deriving stock (Eq, Show, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving Draw via DrawRawChar "_itemType" Item
|
deriving Draw via DrawRawChar "_itemType" Item
|
||||||
deriving (ToJSON, FromJSON)
|
deriving (ToJSON, FromJSON)
|
||||||
|
|
|
@ -40,7 +40,7 @@ data CreatureType = CreatureType
|
||||||
, _friendly :: !Bool
|
, _friendly :: !Bool
|
||||||
, _speed :: !TicksPerTile
|
, _speed :: !TicksPerTile
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Generic)
|
deriving stock (Show, Eq, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving (ToJSON, FromJSON)
|
deriving (ToJSON, FromJSON)
|
||||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||||
|
@ -56,7 +56,7 @@ data EdibleItem = EdibleItem
|
||||||
{ _hitpointsHealed :: Int
|
{ _hitpointsHealed :: Int
|
||||||
, _eatMessage :: Maybe Message
|
, _eatMessage :: Maybe Message
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Generic)
|
deriving stock (Show, Eq, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving (ToJSON, FromJSON)
|
deriving (ToJSON, FromJSON)
|
||||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||||
|
@ -73,7 +73,7 @@ data ItemType = ItemType
|
||||||
, _char :: EntityChar
|
, _char :: EntityChar
|
||||||
, _edible :: Maybe EdibleItem
|
, _edible :: Maybe EdibleItem
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Generic)
|
deriving stock (Show, Eq, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
deriving (ToJSON, FromJSON)
|
deriving (ToJSON, FromJSON)
|
||||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||||
|
|
|
@ -27,7 +27,6 @@ import Xanthous.Prelude
|
||||||
import Brick.Widgets.Edit (Editor, editorText, getEditContents)
|
import Brick.Widgets.Edit (Editor, editorText, getEditContents)
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
import Test.QuickCheck.Arbitrary.Generic
|
import Test.QuickCheck.Arbitrary.Generic
|
||||||
import Control.Comonad
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Util (smallestNotIn)
|
import Xanthous.Util (smallestNotIn)
|
||||||
import Xanthous.Data (Direction, Position)
|
import Xanthous.Data (Direction, Position)
|
||||||
|
|
|
@ -70,7 +70,6 @@ import Data.Aeson.Generic.DerivingVia
|
||||||
import Data.Generics.Product.Fields
|
import Data.Generics.Product.Fields
|
||||||
import qualified Graphics.Vty.Attributes as Vty
|
import qualified Graphics.Vty.Attributes as Vty
|
||||||
import qualified Graphics.Vty.Image as Vty
|
import qualified Graphics.Vty.Image as Vty
|
||||||
import Control.Comonad
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Data
|
import Xanthous.Data
|
||||||
import Xanthous.Data.EntityMap (EntityMap, EntityID)
|
import Xanthous.Data.EntityMap (EntityMap, EntityID)
|
||||||
|
@ -282,7 +281,7 @@ brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
class ( Show a, Eq a, NFData a
|
class ( Show a, Eq a, Ord a, NFData a
|
||||||
, ToJSON a, FromJSON a
|
, ToJSON a, FromJSON a
|
||||||
, Draw a, Brain a
|
, Draw a, Brain a
|
||||||
) => Entity a where
|
) => Entity a where
|
||||||
|
@ -301,6 +300,12 @@ instance Eq SomeEntity where
|
||||||
Just Refl -> a == b
|
Just Refl -> a == b
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
|
instance Ord SomeEntity where
|
||||||
|
compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of
|
||||||
|
Just Refl -> compare a b
|
||||||
|
_ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb)
|
||||||
|
|
||||||
|
|
||||||
instance NFData SomeEntity where
|
instance NFData SomeEntity where
|
||||||
rnf (SomeEntity ent) = ent `deepseq` ()
|
rnf (SomeEntity ent) = ent `deepseq` ()
|
||||||
|
|
||||||
|
|
|
@ -306,6 +306,10 @@ instance FromJSON Attr where
|
||||||
parseStyle Default = pure Default
|
parseStyle Default = pure Default
|
||||||
parseStyle KeepCurrent = pure KeepCurrent
|
parseStyle KeepCurrent = pure KeepCurrent
|
||||||
|
|
||||||
|
deriving stock instance Ord Color
|
||||||
|
deriving stock instance Ord a => Ord (MaybeDefault a)
|
||||||
|
deriving stock instance Ord Attr
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
instance NFData a => NFData (NonNull a) where
|
instance NFData a => NFData (NonNull a) where
|
||||||
|
|
|
@ -7,6 +7,12 @@ module Xanthous.Prelude
|
||||||
, module Control.Lens
|
, module Control.Lens
|
||||||
, module Data.Void
|
, module Data.Void
|
||||||
, module Control.Comonad
|
, module Control.Comonad
|
||||||
|
|
||||||
|
|
||||||
|
-- * Classy-Prelude addons
|
||||||
|
, ninsertSet
|
||||||
|
, ndeleteSet
|
||||||
|
, toVector
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import ClassyPrelude hiding
|
import ClassyPrelude hiding
|
||||||
|
@ -17,3 +23,14 @@ import Control.Lens
|
||||||
import Data.Void
|
import Data.Void
|
||||||
import Control.Comonad
|
import Control.Comonad
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
ninsertSet
|
||||||
|
:: (IsSet set, MonoPointed set)
|
||||||
|
=> Element set -> NonNull set -> NonNull set
|
||||||
|
ninsertSet x xs = impureNonNull $ opoint x `union` toNullable xs
|
||||||
|
|
||||||
|
ndeleteSet :: IsSet b => Element b -> NonNull b -> b
|
||||||
|
ndeleteSet x = deleteSet x . toNullable
|
||||||
|
|
||||||
|
toVector :: (MonoFoldable (f a), Element (f a) ~ a) => f a -> Vector a
|
||||||
|
toVector = fromList . toList
|
||||||
|
|
|
@ -33,7 +33,15 @@ test = localOption (QuickCheckTests 20)
|
||||||
else True
|
else True
|
||||||
]
|
]
|
||||||
, testGroup "JSON encoding/decoding"
|
, testGroup "JSON encoding/decoding"
|
||||||
[ testProperty "Preserves IDs" $ \(em :: EntityMap Int) ->
|
[ 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
|
let Just em' = JSON.decode $ JSON.encode em
|
||||||
in toEIDsAndPositioned em' === toEIDsAndPositioned em
|
in toEIDsAndPositioned em' === toEIDsAndPositioned em
|
||||||
]
|
]
|
||||||
|
|
|
@ -46,6 +46,8 @@ test
|
||||||
]
|
]
|
||||||
, testGroup "Saving the game"
|
, testGroup "Saving the game"
|
||||||
[ testProperty "forms a prism" $ isPrism saved
|
[ testProperty "forms a prism" $ isPrism saved
|
||||||
|
, testProperty "round-trips" $ \gs ->
|
||||||
|
loadGame (saveGame gs) === Just gs
|
||||||
, testProperty "preserves the character ID" $ \gs ->
|
, testProperty "preserves the character ID" $ \gs ->
|
||||||
let Just gs' = loadGame $ saveGame gs
|
let Just gs' = loadGame $ saveGame gs
|
||||||
in gs' ^. character === gs ^. character
|
in gs' ^. character === gs ^. character
|
||||||
|
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 2f93900ad18d56709eb363a7f8dd251a9474dd7092b1aef956389f32c036a121
|
-- hash: 0476b4307dfceb20b9358ca2e6f78c753e3e0a4ae60c6faed54528f6a9c0dc5c
|
||||||
|
|
||||||
name: xanthous
|
name: xanthous
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -96,6 +96,7 @@ library
|
||||||
, megaparsec
|
, megaparsec
|
||||||
, mtl
|
, mtl
|
||||||
, optparse-applicative
|
, optparse-applicative
|
||||||
|
, parallel
|
||||||
, quickcheck-instances
|
, quickcheck-instances
|
||||||
, quickcheck-text
|
, quickcheck-text
|
||||||
, random
|
, random
|
||||||
|
@ -157,7 +158,7 @@ executable xanthous
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
src
|
||||||
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
|
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
|
||||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2
|
||||||
build-depends:
|
build-depends:
|
||||||
MonadRandom
|
MonadRandom
|
||||||
, QuickCheck
|
, QuickCheck
|
||||||
|
@ -182,6 +183,7 @@ executable xanthous
|
||||||
, megaparsec
|
, megaparsec
|
||||||
, mtl
|
, mtl
|
||||||
, optparse-applicative
|
, optparse-applicative
|
||||||
|
, parallel
|
||||||
, quickcheck-instances
|
, quickcheck-instances
|
||||||
, quickcheck-text
|
, quickcheck-text
|
||||||
, random
|
, random
|
||||||
|
@ -220,7 +222,7 @@ test-suite test
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
test
|
test
|
||||||
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
|
default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators
|
||||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O0
|
||||||
build-depends:
|
build-depends:
|
||||||
MonadRandom
|
MonadRandom
|
||||||
, QuickCheck
|
, QuickCheck
|
||||||
|
@ -246,6 +248,7 @@ test-suite test
|
||||||
, megaparsec
|
, megaparsec
|
||||||
, mtl
|
, mtl
|
||||||
, optparse-applicative
|
, optparse-applicative
|
||||||
|
, parallel
|
||||||
, quickcheck-instances
|
, quickcheck-instances
|
||||||
, quickcheck-text
|
, quickcheck-text
|
||||||
, random
|
, random
|
||||||
|
|
Loading…
Reference in a new issue