{-# LANGUAGE ScopedTypeVariables #-}

module Argo.Internal.Codec.Value where

import qualified Argo.Internal.Codec.Codec as Codec
import qualified Argo.Internal.Json.Array as Array
import qualified Argo.Internal.Json.Null as Null
import qualified Argo.Internal.Json.Object as Object
import qualified Argo.Internal.Json.Value as Value
import qualified Argo.Internal.Schema.Identifier as Identifier
import qualified Argo.Internal.Schema.Schema as Schema
import qualified Argo.Vendor.Map as Map
import qualified Argo.Vendor.Text as Text
import qualified Argo.Vendor.Transformers as Trans
import qualified Control.Monad as Monad
import qualified Data.Functor.Identity as Identity
import qualified Data.Typeable as Typeable

decodeWith :: Value a -> Value.Value -> Either String a
decodeWith :: forall a. Value a -> Value -> Either String a
decodeWith Value a
c =
    forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Trans.runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Trans.runReaderT (forall (r :: * -> *) (w :: * -> *) s i o. Codec r w s i o -> r o
Codec.decode Value a
c)

encodeWith :: Value a -> a -> Value.Value
encodeWith :: forall a. Value a -> a -> Value
encodeWith Value a
c a
x =
    forall a b. (a, b) -> b
snd
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
Identity.runIdentity
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Trans.runStateT (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Trans.runMaybeT forall a b. (a -> b) -> a -> b
$ forall (r :: * -> *) (w :: * -> *) s i o.
Codec r w s i o -> i -> w o
Codec.encode Value a
c a
x)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Null -> Value
Value.Null
        forall a b. (a -> b) -> a -> b
$ () -> Null
Null.fromUnit ()

type Value a
    = Codec.Codec
          (Trans.ReaderT Value.Value (Trans.ExceptT String Identity.Identity))
          (Trans.MaybeT (Trans.StateT Value.Value Identity.Identity))
          ( Trans.AccumT
                (Map.Map Identifier.Identifier Schema.Schema)
                Identity.Identity
                (Maybe Identifier.Identifier, Schema.Schema)
          )
          a
          a

arrayCodec :: Value (Array.Array Value.Value)
arrayCodec :: Value (Array Value)
arrayCodec = Codec.Codec
    { decode :: ReaderT Value (ExceptT String Identity) (Array Value)
Codec.decode = do
        Value
x <- forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
        case Value
x of
            Value.Array Array Value
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Array Value
y
            Value
_ ->
                forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Trans.throwE forall a b. (a -> b) -> a -> b
$ String
"expected Array but got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Value
x
    , encode :: Array Value -> MaybeT (StateT Value Identity) (Array Value)
Codec.encode = \Array Value
x -> do
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s. Monad m => s -> StateT s m ()
Trans.put forall a b. (a -> b) -> a -> b
$ Array Value -> Value
Value.Array Array Value
x
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Array Value
x
    , schema :: AccumT (Map Identifier Schema) Identity (Maybe Identifier, Schema)
Codec.schema = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Schema -> (Maybe Identifier, Schema)
Schema.unidentified Schema
Schema.false
    }

objectCodec :: Value (Object.Object Value.Value)
objectCodec :: Value (Object Value)
objectCodec = Codec.Codec
    { decode :: ReaderT Value (ExceptT String Identity) (Object Value)
Codec.decode = do
        Value
x <- forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
        case Value
x of
            Value.Object Object Value
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Object Value
y
            Value
_ ->
                forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Trans.throwE
                    forall a b. (a -> b) -> a -> b
$ String
"expected Object but got "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Value
x
    , encode :: Object Value -> MaybeT (StateT Value Identity) (Object Value)
Codec.encode = \Object Value
x -> do
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s. Monad m => s -> StateT s m ()
Trans.put forall a b. (a -> b) -> a -> b
$ Object Value -> Value
Value.Object Object Value
x
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Object Value
x
    , schema :: AccumT (Map Identifier Schema) Identity (Maybe Identifier, Schema)
Codec.schema = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Schema -> (Maybe Identifier, Schema)
Schema.unidentified Schema
Schema.false
    }

literalCodec :: Value.Value -> Value ()
literalCodec :: Value -> Value ()
literalCodec Value
expected = Codec.Codec
    { decode :: ReaderT Value (ExceptT String Identity) ()
Codec.decode = do
        Value
actual <- forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (Value
actual forall a. Eq a => a -> a -> Bool
/= Value
expected)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Trans.throwE
            forall a b. (a -> b) -> a -> b
$ String
"expected "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Value
expected
            forall a. Semigroup a => a -> a -> a
<> String
" but got "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Value
actual
    , encode :: () -> MaybeT (StateT Value Identity) ()
Codec.encode = forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => s -> StateT s m ()
Trans.put Value
expected
    , schema :: AccumT (Map Identifier Schema) Identity (Maybe Identifier, Schema)
Codec.schema = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> (Maybe Identifier, Schema)
Schema.unidentified forall a b. (a -> b) -> a -> b
$ Value -> Schema
Schema.Const Value
expected
    }

identified :: forall a . Typeable.Typeable a => Value a -> Value a
identified :: forall a. Typeable a => Value a -> Value a
identified = forall a. Identifier -> Value a -> Value a
withIdentifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Identifier
Identifier.fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => Proxy a -> String
typeName
    (forall {k} (t :: k). Proxy t
Typeable.Proxy :: Typeable.Proxy a)

withIdentifier :: Identifier.Identifier -> Value a -> Value a
withIdentifier :: forall a. Identifier -> Value a -> Value a
withIdentifier Identifier
identifier Value a
codec =
    let
        newSchema :: AccumT (Map Identifier Schema) Identity (Maybe Identifier, Schema)
newSchema = do
            (Maybe Identifier
_, Schema
schema) <- forall (r :: * -> *) (w :: * -> *) s i o. Codec r w s i o -> s
Codec.schema Value a
codec
            forall (m :: * -> *) w. Monad m => w -> AccumT w m ()
Trans.add forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Identifier
identifier Schema
schema
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Identifier -> Schema -> (Maybe Identifier, Schema)
Schema.withIdentifier Identifier
identifier Schema
schema
    in Value a
codec { schema :: AccumT (Map Identifier Schema) Identity (Maybe Identifier, Schema)
Codec.schema = AccumT (Map Identifier Schema) Identity (Maybe Identifier, Schema)
newSchema }

typeName :: Typeable.Typeable a => Typeable.Proxy a -> String
typeName :: forall a. Typeable a => Proxy a -> String
typeName = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep

getRef
    :: Value a
    -> Trans.AccumT
           (Map.Map Identifier.Identifier Schema.Schema)
           Identity.Identity
           Schema.Schema
getRef :: forall a. Value a -> AccumT (Map Identifier Schema) Identity Schema
getRef Value a
codec = do
    let
        (Maybe Identifier
maybeIdentifier, Schema
schema) =
            forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
Identity.runIdentity forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
Trans.runAccumT
                (forall (r :: * -> *) (w :: * -> *) s i o. Codec r w s i o -> s
Codec.schema Value a
codec)
                forall k a. Map k a
Map.empty
    case Maybe Identifier
maybeIdentifier of
        Maybe Identifier
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
schema
        Just Identifier
identifier -> do
            Map Identifier Schema
schemas <- forall w (m :: * -> *). (Monoid w, Monad m) => AccumT w m w
Trans.look
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.unless (forall k a. Ord k => k -> Map k a -> Bool
Map.member Identifier
identifier Map Identifier Schema
schemas) forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *) w. Monad m => w -> AccumT w m ()
Trans.add forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Identifier
identifier Schema
schema
                forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void forall a b. (a -> b) -> a -> b
$ forall (r :: * -> *) (w :: * -> *) s i o. Codec r w s i o -> s
Codec.schema Value a
codec
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Identifier -> Schema
Schema.Ref Identifier
identifier