{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Some orphan @To/FromJSON@ instances for terms and values.  We have
-- to put them all here to avoid circular module dependencies.
module Swarm.Language.JSON where

import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON, withText)
import Data.Aeson qualified as Ae
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.Pretty (prettyText)
import Swarm.Util.JSON (optionsMinimize)
import Witch (into)

instance FromJSON TSyntax where
  parseJSON :: Value -> Parser TSyntax
parseJSON = String -> (Text -> Parser TSyntax) -> Value -> Parser TSyntax
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Term" ((Text -> Parser TSyntax) -> Value -> Parser TSyntax)
-> (Text -> Parser TSyntax) -> Value -> Parser TSyntax
forall a b. (a -> b) -> a -> b
$ (Text -> Parser TSyntax)
-> (TSyntax -> Parser TSyntax)
-> Either Text TSyntax
-> Parser TSyntax
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser TSyntax
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser TSyntax)
-> (Text -> String) -> Text -> Parser TSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @String) TSyntax -> Parser TSyntax
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text TSyntax -> Parser TSyntax)
-> (Text -> Either Text TSyntax) -> Text -> Parser TSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text TSyntax
processTermEither

instance ToJSON TSyntax where
  toJSON :: TSyntax -> Value
toJSON = Text -> Value
Ae.String (Text -> Value) -> (TSyntax -> Text) -> TSyntax -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSyntax -> Text
forall a. PrettyPrec a => a -> Text
prettyText

instance FromJSON Term where
  parseJSON :: Value -> Parser Term
parseJSON = Options -> Value -> Parser Term
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
optionsMinimize

instance FromJSON Syntax where
  parseJSON :: Value -> Parser (Syntax' ())
parseJSON = Options -> Value -> Parser (Syntax' ())
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
optionsMinimize

instance ToJSON Term where
  toJSON :: Term -> Value
toJSON = Options -> Term -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
optionsMinimize

instance ToJSON Syntax where
  toJSON :: Syntax' () -> Value
toJSON = Options -> Syntax' () -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
optionsMinimize

instance ToJSON Value where
  toJSON :: Value -> Value
toJSON = Options -> Value -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
optionsMinimize

-- TODO (#2213): Craft some appropriate FromJSONE instances for things
-- like Value and Env.  Below is an early experiment.

-- 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
--     _ -> fail "parseJSONE: Unable to parse Value"

instance ToJSON Env where
  toJSON :: Env -> Value
toJSON = Options -> Env -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
optionsMinimize