[wip] work on FromJSON instances

src/swarm-lang/Swarm/Language/JSON.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- |
@@ -8,13 +9,18 @@
 -- to put them all here to avoid circular module dependencies.
 module Swarm.Language.JSON where
 
-import Data.Aeson (FromJSON (..), ToJSON (..), withText)
+import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON, withText)
 import Data.Aeson qualified as Ae
+import Data.Aeson.KeyMap qualified as Ae
+import Data.Vector qualified as V
+import Swarm.Language.Context (CtxMap, CtxTree)
 import Swarm.Language.Pipeline (processTermEither)
 import Swarm.Language.Syntax (Term)
 import Swarm.Language.Syntax.Pattern (Syntax, TSyntax)
-import Swarm.Language.Value (Env, Value)
+import Swarm.Language.Value (Env, Value (..))
 import Swarm.Pretty (prettyText)
+import Swarm.Util.JSON (optionsMinimize)
+import Swarm.Util.Yaml (FromJSONE, liftE, parseJSONE, withObjectE)
 import Witch (into)
 
 instance FromJSON TSyntax where
@@ -29,13 +35,42 @@ instance ToJSON Term
 instance ToJSON Syntax
 
 instance ToJSON Value where
-  toJSON = undefined
+  toJSON = genericToJSON optionsMinimize
 
-instance FromJSON Value where
-  parseJSON = undefined
+instance FromJSONE (CtxMap CtxTree t) Value where
+  parseJSONE = withObjectE "Value" $ \v -> case Ae.toList v of
+    [("VUnit", _)] -> pure VUnit
+    [("VInt", n)] -> VInt <$> liftE (parseJSON n)
+    [("VText", t)] -> VText <$> liftE (parseJSON t)
+    [("VInj", Ae.Array (V.toList -> [i, x]))] -> VInj <$> liftE (parseJSON i) <*> parseJSONE x
+    [("VPair", Ae.Array (V.toList -> [v1,v2]))] -> VPair <$> parseJSONE v1 <*> parseJSONE v2
+    [("VClo", Ae.Array (V.toList -> [x,t,e]))] ->
+      VClo <$> liftE (parseJSON x) <*> liftE (parseJSON t) <*> parseJSONE e
+    [("VCApp", Ae.Array (V.toList -> [c, vs]))] ->
+      VCApp <$> liftE (parseJSON c) <*> parseJSONE vs
+    [("VBind", Ae.Array (V.toList -> [x,ty,r,t1,t2,e]))] ->
+      VBind
+        <$> liftE (parseJSON x)
+        <*> liftE (parseJSON ty)
+        <*> liftE (parseJSON r)
+        <*> liftE (parseJSON t1)
+        <*> liftE (parseJSON t2)
+        <*> parseJSONE e
+    [("VDelay", Ae.Array (V.toList -> [t, e]))] ->
+      VDelay <$> liftE (parseJSON t) <*> parseJSONE e
+    [("VRef", n)] -> VRef <$> liftE (parseJSON n)
+    [("VIndir", n)] -> VIndir <$> liftE (parseJSON n)
+    [("VRcd", m)] -> VRcd <$> parseJSONE m
+    [("VKey", k)] -> VKey <$> liftE (parseJSON k)
+    [("VRequirements", Ae.Array (V.toList -> [txt, t, e]))] ->
+      VRequirements <$> liftE (parseJSON txt) <*> liftE (parseJSON t) <*> parseJSONE e
+    [("VSuspend", Ae.Array (V.toList -> [t, e]))] ->
+      VSuspend <$> liftE (parseJSON t) <*> parseJSONE e
+    [("VExc",_)] -> pure VExc
+    [("VBlackhole",_)] -> pure VBlackhole
 
 instance ToJSON Env where
-  toJSON = undefined
+  toJSON = genericToJSON optionsMinimize
 
-instance FromJSON Env where
-  parseJSON = undefined
+instance FromJSONE (CtxMap CtxTree t) Env where
+  parseJSONE = undefined

src/swarm-util/Swarm/Util/Yaml.hs

@@ -29,6 +29,7 @@ import Control.Monad.Reader
 import Data.Aeson.Key (fromText)
 import Data.Aeson.Types (explicitParseField, explicitParseFieldMaybe)
 import Data.Bifunctor (first)
+import Data.Map (Map)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Vector qualified as V
@@ -101,6 +102,9 @@ instance (FromJSONE e a, FromJSONE e b) => FromJSONE e (a, b) where
               <*> parseJSONE (V.unsafeIndex t 1)
           else failT ["cannot unpack array of length", showT n, "into a tuple of length 2"]
 
+instance (FromJSONE e a) => FromJSONE e (Map k a) where
+  parseJSONE = undefined
+
 ------------------------------------------------------------
 -- Decoding
 ------------------------------------------------------------