blob: a0c037a1b4ed12081f217d84648f05ebc6df9e43 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--------------------------------------------------------------------------------
module Xanthous.Entities.Entities () where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Test.QuickCheck
import qualified Test.QuickCheck.Gen as Gen
import Data.Aeson
--------------------------------------------------------------------------------
import Xanthous.Entities.Character
import Xanthous.Entities.Item
import Xanthous.Entities.Creature
import Xanthous.Entities.Environment
import Xanthous.Entities.Marker
import Xanthous.Game.State
import Xanthous.Util.QuickCheck
import Data.Aeson.Generic.DerivingVia
--------------------------------------------------------------------------------
instance Arbitrary SomeEntity where
arbitrary = Gen.oneof
[ SomeEntity <$> arbitrary @Character
, SomeEntity <$> arbitrary @Item
, SomeEntity <$> arbitrary @Creature
, SomeEntity <$> arbitrary @Wall
, SomeEntity <$> arbitrary @Door
, SomeEntity <$> arbitrary @GroundMessage
, SomeEntity <$> arbitrary @Staircase
, SomeEntity <$> arbitrary @Marker
]
instance FromJSON SomeEntity where
parseJSON = withObject "Entity" $ \obj -> do
(entityType :: Text) <- obj .: "type"
case entityType of
"Character" -> SomeEntity @Character <$> obj .: "data"
"Item" -> SomeEntity @Item <$> obj .: "data"
"Creature" -> SomeEntity @Creature <$> obj .: "data"
"Wall" -> SomeEntity @Wall <$> obj .: "data"
"Door" -> SomeEntity @Door <$> obj .: "data"
"GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data"
"Staircase" -> SomeEntity @Staircase <$> obj .: "data"
"Marker" -> SomeEntity @Marker <$> obj .: "data"
_ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel
instance FromJSON GameLevel
deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
instance FromJSON GameState
instance Entity SomeEntity where
entityAttributes (SomeEntity ent) = entityAttributes ent
description (SomeEntity ent) = description ent
entityChar (SomeEntity ent) = entityChar ent
entityCollision (SomeEntity ent) = entityCollision ent
instance Function SomeEntity where
function = functionJSON
instance CoArbitrary SomeEntity where
coarbitrary = coarbitrary . encode
|
