From 30d83d7c828f7bf5ed285f71e5b4a7bf095002b5 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 13 Jun 2021 23:02:11 -0400 Subject: feat(xanthous): Add a method to get the name for a type of entity I didn't end up using this directly for the thing I was doing, but it still seems generally useful enough that I'm keeping it around for now Change-Id: I05c8902d75845f2230ec2373a9677d61cfaafafd Reviewed-on: https://cl.tvl.fyi/c/depot/+/3206 Reviewed-by: grfn Tested-by: BuildkiteCI --- users/grfn/xanthous/src/Xanthous/Game/State.hs | 6 ++++++ users/grfn/xanthous/test/Spec.hs | 2 ++ .../grfn/xanthous/test/Xanthous/Game/StateSpec.hs | 25 ++++++++++++++++++++++ users/grfn/xanthous/xanthous.cabal | 3 ++- 4 files changed, 35 insertions(+), 1 deletion(-) create mode 100644 users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs (limited to 'users/grfn') diff --git a/users/grfn/xanthous/src/Xanthous/Game/State.hs b/users/grfn/xanthous/src/Xanthous/Game/State.hs index cdaf23edcd48..6f51683d14fe 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/State.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/State.hs @@ -56,6 +56,8 @@ module Xanthous.Game.State , downcastEntity , _SomeEntity , entityIs + , entityTypeName + -- ** Vias , Color(..) , DrawNothing(..) @@ -394,6 +396,10 @@ entityIs = isJust . downcastEntity @a _SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a _SomeEntity = prism' SomeEntity downcastEntity +-- | Get the name of the type of 'SomeEntity' as a string +entityTypeName :: SomeEntity -> Text +entityTypeName (SomeEntity e) = pack . tyConName . typeRepTyCon $ typeOf e + newtype DeriveEntity (blocksVision :: Bool) (description :: Symbol) diff --git a/users/grfn/xanthous/test/Spec.hs b/users/grfn/xanthous/test/Spec.hs index e71434863902..46e82c8c6c6b 100644 --- a/users/grfn/xanthous/test/Spec.hs +++ b/users/grfn/xanthous/test/Spec.hs @@ -11,6 +11,7 @@ import qualified Xanthous.Data.NestedMapSpec import qualified Xanthous.DataSpec import qualified Xanthous.Entities.RawsSpec import qualified Xanthous.GameSpec +import qualified Xanthous.Game.StateSpec import qualified Xanthous.Generators.Level.UtilSpec import qualified Xanthous.MessageSpec import qualified Xanthous.Messages.TemplateSpec @@ -36,6 +37,7 @@ test = testGroup "Xanthous" , Xanthous.DataSpec.test , Xanthous.Entities.RawsSpec.test , Xanthous.GameSpec.test + , Xanthous.Game.StateSpec.test , Xanthous.Generators.Level.UtilSpec.test , Xanthous.MessageSpec.test , Xanthous.Messages.TemplateSpec.test diff --git a/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs b/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs new file mode 100644 index 000000000000..3267d8ef9e9c --- /dev/null +++ b/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs @@ -0,0 +1,25 @@ +-------------------------------------------------------------------------------- +module Xanthous.Game.StateSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import Xanthous.Game.State +import Xanthous.Entities.Raws (raws, entityFromRaw) +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Game.StateSpec" + [ testGroup "entityTypeName" + [ testCase "for a creature" $ + let gormlakRaw = raws ^?! ix "gormlak" + creature = entityFromRaw gormlakRaw + in entityTypeName creature @?= "Creature" + , testCase "for an item" $ + let stickRaw = raws ^?! ix "stick" + item = entityFromRaw stickRaw + in entityTypeName item @?= "Item" + ] + ] diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal index 3ad667f62bee..3880969d7d39 100644 --- a/users/grfn/xanthous/xanthous.cabal +++ b/users/grfn/xanthous/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 3887c4e473843f80e65cb0ae8a1def8fc4871de33e9f425a08820e9a8942e99c +-- hash: 715e0ab333afb8723ffec128cf69c065f6f018e9622d65c45d404e5084852f54 name: xanthous version: 0.1.0.0 @@ -356,6 +356,7 @@ test-suite test Xanthous.Data.NestedMapSpec Xanthous.DataSpec Xanthous.Entities.RawsSpec + Xanthous.Game.StateSpec Xanthous.GameSpec Xanthous.Generators.Level.UtilSpec Xanthous.Messages.TemplateSpec -- cgit 1.4.1