diff --git a/src/swarm-lang/Swarm/Language/Context.hs b/src/swarm-lang/Swarm/Language/Context.hs index 34c51b398..a88aa2faf 100644 --- a/src/swarm-lang/Swarm/Language/Context.hs +++ b/src/swarm-lang/Swarm/Language/Context.hs @@ -15,7 +15,7 @@ import Control.Effect.Reader (Reader, ask, local) import Control.Effect.State (State, get, modify) import Control.Lens.Empty (AsEmpty (..)) import Control.Lens.Prism (prism) -import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey, genericParseJSON, genericToJSON, withText) import Data.Data (Data) import Data.Function (on) import Data.Functor.Const @@ -25,11 +25,14 @@ import Data.Map (Map) import Data.Map qualified as M import Data.Semigroup (Sum (..)) import Data.Text (Text) +import Data.Text qualified as T import GHC.Generics (Generic) import Swarm.Pretty (PrettyPrec (..)) import Swarm.Util (failT, showT) +import Swarm.Util.JSON (optionsMinimize) import Swarm.Util.Yaml (FromJSONE, getE, liftE, parseJSONE) import Text.Printf (printf) +import Text.Read (readMaybe) import Prelude hiding (lookup) -- | We use 'Text' values to represent variables. @@ -51,13 +54,21 @@ type Var = Text -- functional, without the need to thread around some kind of -- globally unique ID generation effect. newtype CtxHash = CtxHash {getCtxHash :: Int} - deriving (Eq, Ord, Data, Generic, ToJSON, FromJSON) + deriving (Eq, Ord, Data, Generic, ToJSONKey, FromJSONKey) deriving (Semigroup, Monoid) via Sum Int deriving (Num) via Int instance Show CtxHash where show (CtxHash h) = printf "%016x" h +instance ToJSON CtxHash where + toJSON h = toJSON (show h) + +instance FromJSON CtxHash where + parseJSON = withText "hash" $ \t -> case readMaybe ("0x" ++ T.unpack t) of + Nothing -> fail "Could not parse CtxHash" + Just h -> pure (CtxHash h) + -- | The hash for a single variable -> value binding. singletonHash :: Hashable t => Var -> t -> CtxHash singletonHash x t = CtxHash $ hashWithSalt (hash x) t @@ -76,7 +87,13 @@ data CtxF f t | CtxSingle Var t | CtxDelete Var t (f t) | CtxUnion (f t) (f t) - deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic, ToJSON, FromJSON) + deriving (Eq, Show, Functor, Foldable, Traversable, Data, Generic) + +instance (ToJSON t, ToJSON (f t)) => ToJSON (CtxF f t) where + toJSON = genericToJSON optionsMinimize + +instance (FromJSON t, FromJSON (f t)) => FromJSON (CtxF f t) where + parseJSON = genericParseJSON optionsMinimize -- | Map over the recursive structure stored in a 'CtxF'. restructure :: (f t -> g t) -> CtxF f t -> CtxF g t