{-# LANGUAGE ScopedTypeVariables #-}

module Argo.Codec.Value where

import qualified Argo.Codec.Codec as Codec
import qualified Argo.Json.Array as Array
import qualified Argo.Json.Null as Null
import qualified Argo.Json.Object as Object
import qualified Argo.Json.Value as Value
import qualified Argo.Schema.Identifier as Identifier
import qualified Argo.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 :: Value a -> Value -> Either String a
decodeWith Value a
c =
    Identity (Either String a) -> Either String a
forall a. Identity a -> a
Identity.runIdentity (Identity (Either String a) -> Either String a)
-> (Value -> Identity (Either String a))
-> Value
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String Identity a -> Identity (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Trans.runExceptT (ExceptT String Identity a -> Identity (Either String a))
-> (Value -> ExceptT String Identity a)
-> Value
-> Identity (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Value (ExceptT String Identity) a
-> Value -> ExceptT String Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Trans.runReaderT (Value a -> ReaderT Value (ExceptT String Identity) a
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 :: Value a -> a -> Value
encodeWith Value a
c a
x =
    (Maybe a, Value) -> Value
forall a b. (a, b) -> b
snd
        ((Maybe a, Value) -> Value)
-> (Null -> (Maybe a, Value)) -> Null -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Maybe a, Value) -> (Maybe a, Value)
forall a. Identity a -> a
Identity.runIdentity
        (Identity (Maybe a, Value) -> (Maybe a, Value))
-> (Null -> Identity (Maybe a, Value)) -> Null -> (Maybe a, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT Value Identity (Maybe a)
-> Value -> Identity (Maybe a, Value)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Trans.runStateT (MaybeT (StateT Value Identity) a -> StateT Value Identity (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Trans.runMaybeT (MaybeT (StateT Value Identity) a
 -> StateT Value Identity (Maybe a))
-> MaybeT (StateT Value Identity) a
-> StateT Value Identity (Maybe a)
forall a b. (a -> b) -> a -> b
$ Value a -> a -> MaybeT (StateT Value Identity) a
forall (r :: * -> *) (w :: * -> *) s i o.
Codec r w s i o -> i -> w o
Codec.encode Value a
c a
x)
        (Value -> Identity (Maybe a, Value))
-> (Null -> Value) -> Null -> Identity (Maybe a, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Null -> Value
Value.Null
        (Null -> Value) -> Null -> Value
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 :: forall (r :: * -> *) (w :: * -> *) s i o.
r o -> (i -> w o) -> s -> Codec r w s i o
Codec.Codec
    { decode :: ReaderT Value (ExceptT String Identity) (Array Value)
Codec.decode = do
        Value
x <- ReaderT Value (ExceptT String Identity) Value
forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
        case Value
x of
            Value.Array Array Value
y -> Array Value
-> ReaderT Value (ExceptT String Identity) (Array Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Array Value
y
            Value
_ ->
                ExceptT String Identity (Array Value)
-> ReaderT Value (ExceptT String Identity) (Array Value)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (ExceptT String Identity (Array Value)
 -> ReaderT Value (ExceptT String Identity) (Array Value))
-> (String -> ExceptT String Identity (Array Value))
-> String
-> ReaderT Value (ExceptT String Identity) (Array Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String Identity (Array Value)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Trans.throwE (String -> ReaderT Value (ExceptT String Identity) (Array Value))
-> String -> ReaderT Value (ExceptT String Identity) (Array Value)
forall a b. (a -> b) -> a -> b
$ String
"expected Array but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
x
    , encode :: Array Value -> MaybeT (StateT Value Identity) (Array Value)
Codec.encode = \Array Value
x -> do
        StateT Value Identity () -> MaybeT (StateT Value Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (StateT Value Identity () -> MaybeT (StateT Value Identity) ())
-> (Value -> StateT Value Identity ())
-> Value
-> MaybeT (StateT Value Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> StateT Value Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
Trans.put (Value -> MaybeT (StateT Value Identity) ())
-> Value -> MaybeT (StateT Value Identity) ()
forall a b. (a -> b) -> a -> b
$ Array Value -> Value
Value.Array Array Value
x
        Array Value -> MaybeT (StateT Value Identity) (Array Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Array Value
x
    , schema :: AccumT (Map Identifier Schema) Identity (Maybe Identifier, Schema)
Codec.schema = (Maybe Identifier, Schema)
-> AccumT
     (Map Identifier Schema) Identity (Maybe Identifier, Schema)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe Identifier, Schema)
 -> AccumT
      (Map Identifier Schema) Identity (Maybe Identifier, Schema))
-> (Maybe Identifier, Schema)
-> AccumT
     (Map Identifier Schema) Identity (Maybe Identifier, Schema)
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 :: forall (r :: * -> *) (w :: * -> *) s i o.
r o -> (i -> w o) -> s -> Codec r w s i o
Codec.Codec
    { decode :: ReaderT Value (ExceptT String Identity) (Object Value)
Codec.decode = do
        Value
x <- ReaderT Value (ExceptT String Identity) Value
forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
        case Value
x of
            Value.Object Object Value
y -> Object Value
-> ReaderT Value (ExceptT String Identity) (Object Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object Value
y
            Value
_ ->
                ExceptT String Identity (Object Value)
-> ReaderT Value (ExceptT String Identity) (Object Value)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift
                    (ExceptT String Identity (Object Value)
 -> ReaderT Value (ExceptT String Identity) (Object Value))
-> (String -> ExceptT String Identity (Object Value))
-> String
-> ReaderT Value (ExceptT String Identity) (Object Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String Identity (Object Value)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Trans.throwE
                    (String -> ReaderT Value (ExceptT String Identity) (Object Value))
-> String -> ReaderT Value (ExceptT String Identity) (Object Value)
forall a b. (a -> b) -> a -> b
$ String
"expected Object but got "
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
x
    , encode :: Object Value -> MaybeT (StateT Value Identity) (Object Value)
Codec.encode = \Object Value
x -> do
        StateT Value Identity () -> MaybeT (StateT Value Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (StateT Value Identity () -> MaybeT (StateT Value Identity) ())
-> (Value -> StateT Value Identity ())
-> Value
-> MaybeT (StateT Value Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> StateT Value Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
Trans.put (Value -> MaybeT (StateT Value Identity) ())
-> Value -> MaybeT (StateT Value Identity) ()
forall a b. (a -> b) -> a -> b
$ Object Value -> Value
Value.Object Object Value
x
        Object Value -> MaybeT (StateT Value Identity) (Object Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object Value
x
    , schema :: AccumT (Map Identifier Schema) Identity (Maybe Identifier, Schema)
Codec.schema = (Maybe Identifier, Schema)
-> AccumT
     (Map Identifier Schema) Identity (Maybe Identifier, Schema)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe Identifier, Schema)
 -> AccumT
      (Map Identifier Schema) Identity (Maybe Identifier, Schema))
-> (Maybe Identifier, Schema)
-> AccumT
     (Map Identifier Schema) Identity (Maybe Identifier, Schema)
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 :: forall (r :: * -> *) (w :: * -> *) s i o.
r o -> (i -> w o) -> s -> Codec r w s i o
Codec.Codec
    { decode :: ReaderT Value (ExceptT String Identity) ()
Codec.decode = do
        Value
actual <- ReaderT Value (ExceptT String Identity) Value
forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
        Bool
-> ReaderT Value (ExceptT String Identity) ()
-> ReaderT Value (ExceptT String Identity) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (Value
actual Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
expected)
            (ReaderT Value (ExceptT String Identity) ()
 -> ReaderT Value (ExceptT String Identity) ())
-> (String -> ReaderT Value (ExceptT String Identity) ())
-> String
-> ReaderT Value (ExceptT String Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String Identity ()
-> ReaderT Value (ExceptT String Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift
            (ExceptT String Identity ()
 -> ReaderT Value (ExceptT String Identity) ())
-> (String -> ExceptT String Identity ())
-> String
-> ReaderT Value (ExceptT String Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String Identity ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Trans.throwE
            (String -> ReaderT Value (ExceptT String Identity) ())
-> String -> ReaderT Value (ExceptT String Identity) ()
forall a b. (a -> b) -> a -> b
$ String
"expected "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
expected
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
actual
    , encode :: () -> MaybeT (StateT Value Identity) ()
Codec.encode = MaybeT (StateT Value Identity) ()
-> () -> MaybeT (StateT Value Identity) ()
forall a b. a -> b -> a
const (MaybeT (StateT Value Identity) ()
 -> () -> MaybeT (StateT Value Identity) ())
-> (StateT Value Identity () -> MaybeT (StateT Value Identity) ())
-> StateT Value Identity ()
-> ()
-> MaybeT (StateT Value Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT Value Identity () -> MaybeT (StateT Value Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (StateT Value Identity ()
 -> () -> MaybeT (StateT Value Identity) ())
-> StateT Value Identity ()
-> ()
-> MaybeT (StateT Value Identity) ()
forall a b. (a -> b) -> a -> b
$ Value -> StateT Value Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
Trans.put Value
expected
    , schema :: AccumT (Map Identifier Schema) Identity (Maybe Identifier, Schema)
Codec.schema = (Maybe Identifier, Schema)
-> AccumT
     (Map Identifier Schema) Identity (Maybe Identifier, Schema)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe Identifier, Schema)
 -> AccumT
      (Map Identifier Schema) Identity (Maybe Identifier, Schema))
-> (Schema -> (Maybe Identifier, Schema))
-> Schema
-> AccumT
     (Map Identifier Schema) Identity (Maybe Identifier, Schema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> (Maybe Identifier, Schema)
Schema.unidentified (Schema
 -> AccumT
      (Map Identifier Schema) Identity (Maybe Identifier, Schema))
-> Schema
-> AccumT
     (Map Identifier Schema) Identity (Maybe Identifier, Schema)
forall a b. (a -> b) -> a -> b
$ Value -> Schema
Schema.Const Value
expected
    }

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

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