From fd78831a3a41ac10ea42953f760503a5ad21a058 Mon Sep 17 00:00:00 2001 From: Tristan Cacqueray Date: Sun, 26 Jun 2022 17:24:02 +0000 Subject: [PATCH] Add State instances --- src/Swarm/Game/CESK.hs | 8 ++++---- src/Swarm/Game/Entity.hs | 1 + src/Swarm/Game/Recipe.hs | 11 ++++++++--- src/Swarm/Game/Scenario.hs | 2 ++ src/Swarm/Game/State.hs | 16 +++++++++++----- src/Swarm/Language/Capability.hs | 3 ++- src/Swarm/Language/Pipeline.hs | 5 ++++- src/Swarm/Language/Types.hs | 2 +- 8 files changed, 33 insertions(+), 15 deletions(-) diff --git a/src/Swarm/Game/CESK.hs b/src/Swarm/Game/CESK.hs index 17f5aa2feb..0552e0ef88 100644 --- a/src/Swarm/Game/CESK.hs +++ b/src/Swarm/Game/CESK.hs @@ -90,8 +90,7 @@ module Swarm.Game.CESK ( ) where import Control.Lens.Combinators (pattern Empty) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson +import Data.Aeson (FromJSON, Null, ToJSON) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM import Data.List (intercalate) @@ -379,7 +378,8 @@ instance Eq WorldUpdate where _ == _ = True instance Eq RobotUpdate where _ == _ = True +-- TODO: remove these instances once Update fields are concret instance FromJSON WorldUpdate where parseJSON _ = pure $ WorldUpdate $ \w -> Right w -instance ToJSON WorldUpdate where toJSON _ = Data.Aeson.Null +instance ToJSON WorldUpdate where toJSON _ = Null instance FromJSON RobotUpdate where parseJSON _ = pure $ RobotUpdate id -instance ToJSON RobotUpdate where toJSON _ = Data.Aeson.Null +instance ToJSON RobotUpdate where toJSON _ = Null diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs index 0de9d1be6a..a06a852867 100644 --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -293,6 +293,7 @@ data EntityMap = EntityMap { entitiesByName :: Map Text Entity , entitiesByCap :: Map Capability [Entity] } + deriving (Generic, FromJSON, ToJSON) instance Semigroup EntityMap where EntityMap n1 c1 <> EntityMap n2 c2 = EntityMap (n1 <> n2) (c1 <> c2) diff --git a/src/Swarm/Game/Recipe.hs b/src/Swarm/Game/Recipe.hs index 4edfecaf90..3e800c1914 100644 --- a/src/Swarm/Game/Recipe.hs +++ b/src/Swarm/Game/Recipe.hs @@ -1,10 +1,11 @@ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -50,6 +51,7 @@ import Data.List (foldl') import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import GHC.Generics (Generic) import Witch import Data.Yaml @@ -79,7 +81,10 @@ data Recipe e = Recipe , _recipeTime :: Integer , _recipeWeight :: Integer } - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) + +deriving instance ToJSON (Recipe Entity) +deriving instance FromJSON (Recipe Entity) makeLensesWith (lensRules & generateSignatures .~ False) ''Recipe diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index 091ce7c8ee..2b3c34c095 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index ff8ca4b2c0..cf11813156 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -89,6 +93,7 @@ import Control.Applicative ((<|>)) import Control.Arrow (Arrow ((&&&))) import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) import Control.Monad.Except +import Data.Aeson (FromJSON, ToJSON) import Data.Array (Array, listArray) import Data.Int (Int64) import Data.IntMap (IntMap) @@ -104,6 +109,7 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T (lines) import qualified Data.Text.IO as T (readFile) +import GHC.Generics (Generic) import Linear import qualified System.Clock import System.Random (StdGen, mkStdGen, randomRIO) @@ -141,7 +147,7 @@ data ViewCenterRule VCLocation (V2 Int64) | -- | The view should be centered on a certain robot. VCRobot RID - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) makePrisms ''ViewCenterRule @@ -154,7 +160,7 @@ data REPLStatus -- entered. The @Maybe Value@ starts out as @Nothing@ and gets -- filled in with a result once the command completes. REPLWorking Polytype (Maybe Value) - deriving (Eq, Show) + deriving (Eq, Show, Generic, FromJSON, ToJSON) data WinCondition = -- | There is no winning condition. @@ -165,7 +171,7 @@ data WinCondition | -- | The player has won. The boolean indicates whether they have -- already been congratulated. Won Bool - deriving (Show) + deriving (Show, Generic, FromJSON, ToJSON) makePrisms ''WinCondition @@ -178,14 +184,14 @@ data RunStatus | -- | The game got paused while visiting the help, -- and it should unpause after returning back to the game. AutoPause - deriving (Eq, Show) + deriving (Eq, Show, Generic, FromJSON, ToJSON) -- | A data type to keep track of discovered recipes and commands data Notifications a = Notifications { _notificationsCount :: Int , _notificationsContent :: [a] } - deriving (Eq, Show) + deriving (Eq, Show, Generic, FromJSON, ToJSON) instance Semigroup (Notifications a) where Notifications count1 xs1 <> Notifications count2 xs2 = Notifications (count1 + count2) (xs1 <> xs2) diff --git a/src/Swarm/Language/Capability.hs b/src/Swarm/Language/Capability.hs index baacc553fe..f6dca2903e 100644 --- a/src/Swarm/Language/Capability.hs +++ b/src/Swarm/Language/Capability.hs @@ -23,6 +23,7 @@ module Swarm.Language.Capability ( constCaps, ) where +import Data.Aeson (FromJSONKey, ToJSONKey) import Data.Char (toLower) import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) @@ -113,7 +114,7 @@ data Capability -- checking challenge mode win conditions, and not for use by -- players. CGod - deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data) + deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data, FromJSONKey, ToJSONKey) capabilityName :: Capability -> Text capabilityName = from @String . map toLower . drop 1 . show diff --git a/src/Swarm/Language/Pipeline.hs b/src/Swarm/Language/Pipeline.hs index 0ea3675ccf..ed3a460842 100644 --- a/src/Swarm/Language/Pipeline.hs +++ b/src/Swarm/Language/Pipeline.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -27,6 +29,7 @@ import Data.Data (Data) import Data.Set (Set) import Data.Text (Text) import Data.Yaml as Y +import GHC.Generics (Generic) import Witch import Swarm.Language.Capability @@ -50,7 +53,7 @@ data ProcessedTerm -- ^ Capabilities required by the term CapCtx -- ^ Capability context for any definitions embedded in the term - deriving (Data, Show) + deriving (Data, Show, Generic, ToJSON) instance FromJSON ProcessedTerm where parseJSON = withText "Term" tryProcess diff --git a/src/Swarm/Language/Types.hs b/src/Swarm/Language/Types.hs index a3e9485a9c..b3b525f770 100644 --- a/src/Swarm/Language/Types.hs +++ b/src/Swarm/Language/Types.hs @@ -228,7 +228,7 @@ type UPolytype = Poly UType -- contains the overall type of the expression, as well as the -- context giving the types of any defined variables. data Module s t = Module {moduleTy :: s, moduleCtx :: Ctx t} - deriving (Show, Eq, Functor, Data) + deriving (Show, Eq, Functor, Data, Generic, FromJSON, ToJSON) -- | A 'TModule' is the final result of the type inference process on -- an expression: we get a polytype for the expression, and a