module Argo.Codec.Object where

import qualified Argo.Codec.Codec as Codec
import qualified Argo.Codec.List as Codec
import qualified Argo.Codec.Value as Codec
import qualified Argo.Json.Array as Array
import qualified Argo.Json.Boolean as Boolean
import qualified Argo.Json.Member as Member
import qualified Argo.Json.Name as Name
import qualified Argo.Json.Object as Object
import qualified Argo.Json.String as String
import qualified Argo.Json.Value as Value
import qualified Argo.Schema.Schema as Schema
import qualified Argo.Type.Permission as Permission
import qualified Argo.Vendor.Text as Text
import qualified Argo.Vendor.Transformers as Trans
import qualified Control.Monad as Monad
import qualified Data.List as List
import qualified Data.Maybe as Maybe

type Object a
    = Codec.List
          [(Name.Name, Bool, Schema.Schema)]
          (Member.Member Value.Value)
          a

fromObjectCodec :: Permission.Permission -> Object a -> Codec.Value a
fromObjectCodec :: Permission -> Object a -> Value a
fromObjectCodec =
    (Permission -> [(Name, Bool, Schema)] -> Schema)
-> Value [Member Value] -> Permission -> Object a -> Value a
forall s e a.
(Permission -> s -> Schema)
-> Value [e] -> Permission -> List s e a -> Value a
Codec.fromListCodec
            (\Permission
permission [(Name, Bool, Schema)]
schemas ->
                Value -> Schema
Schema.fromValue (Value -> Schema)
-> (Object Value -> Value) -> Object Value -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object Value -> Value
Value.Object (Object Value -> Schema) -> Object Value -> Schema
forall a b. (a -> b) -> a -> b
$ [Member Value] -> Object Value
forall value. [Member value] -> Object value
Object.fromList
                    [ (Name, Value) -> Member Value
forall value. (Name, value) -> Member value
Member.fromTuple
                        ( String -> Name
Name.fromString (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
String.fromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
"type"
                        , String -> Value
Value.String (String -> Value) -> (Text -> String) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
String.fromText (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
"object"
                        )
                    , (Name, Value) -> Member Value
forall value. (Name, value) -> Member value
Member.fromTuple
                        ( String -> Name
Name.fromString (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
String.fromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack
                            String
"properties"
                        , Object Value -> Value
Value.Object (Object Value -> Value)
-> ([Member Value] -> Object Value) -> [Member Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Member Value] -> Object Value
forall value. [Member value] -> Object value
Object.fromList ([Member Value] -> Value) -> [Member Value] -> Value
forall a b. (a -> b) -> a -> b
$ ((Name, Bool, Schema) -> Member Value)
-> [(Name, Bool, Schema)] -> [Member Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                            (\(Name
k, Bool
_, Schema
s) ->
                                (Name, Value) -> Member Value
forall value. (Name, value) -> Member value
Member.fromTuple (Name
k, Schema -> Value
Schema.toValue Schema
s)
                            )
                            [(Name, Bool, Schema)]
schemas
                        )
                    , (Name, Value) -> Member Value
forall value. (Name, value) -> Member value
Member.fromTuple
                        ( String -> Name
Name.fromString (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
String.fromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack
                            String
"required"
                        , Array Value -> Value
Value.Array (Array Value -> Value)
-> ([Value] -> Array Value) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array Value
forall value. [value] -> Array value
Array.fromList ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ ((Name, Bool, Schema) -> Maybe Value)
-> [(Name, Bool, Schema)] -> [Value]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe
                            (\(Name
k, Bool
r, Schema
_) -> if Bool
r
                                then Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> (String -> Value) -> String -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Value
Value.String (String -> Maybe Value) -> String -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Name -> String
Name.toString Name
k
                                else Maybe Value
forall a. Maybe a
Nothing
                            )
                            [(Name, Bool, Schema)]
schemas
                        )
                    , (Name, Value) -> Member Value
forall value. (Name, value) -> Member value
Member.fromTuple
                        ( String -> Name
Name.fromString (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
String.fromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack
                            String
"additionalProperties"
                        , Boolean -> Value
Value.Boolean (Boolean -> Value) -> (Bool -> Boolean) -> Bool -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Boolean
Boolean.fromBool (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ case Permission
permission of
                            Permission
Permission.Allow -> Bool
True
                            Permission
Permission.Forbid -> Bool
False
                        )
                    ]
            )
        (Value [Member Value] -> Permission -> Object a -> Value a)
-> Value [Member Value] -> Permission -> Object a -> Value a
forall a b. (a -> b) -> a -> b
$ (Object Value -> [Member Value])
-> ([Member Value] -> Object Value)
-> Codec
     (ReaderT Value (ExceptT String Identity))
     (MaybeT (StateT Value Identity))
     Schema
     (Object Value)
     (Object Value)
-> Value [Member Value]
forall (r :: * -> *) (w :: * -> *) a b s.
(Functor r, Functor w) =>
(a -> b) -> (b -> a) -> Codec r w s a a -> Codec r w s b b
Codec.map Object Value -> [Member Value]
forall value. Object value -> [Member value]
Object.toList [Member Value] -> Object Value
forall value. [Member value] -> Object value
Object.fromList Codec
  (ReaderT Value (ExceptT String Identity))
  (MaybeT (StateT Value Identity))
  Schema
  (Object Value)
  (Object Value)
Codec.objectCodec

required :: Name.Name -> Codec.Value a -> Object a
required :: Name -> Value a -> Object a
required Name
k Value a
c = Codec :: forall (r :: * -> *) (w :: * -> *) s i o.
r o -> (i -> w o) -> s -> Codec r w s i o
Codec.Codec
    { decode :: StateT [Member Value] (ExceptT String Identity) a
Codec.decode = do
        Maybe a
m <- Codec
  (StateT [Member Value] (ExceptT String Identity))
  (WriterT [Member Value] Identity)
  [(Name, Bool, Schema)]
  (Maybe a)
  (Maybe a)
-> StateT [Member Value] (ExceptT String Identity) (Maybe a)
forall (r :: * -> *) (w :: * -> *) s i o. Codec r w s i o -> r o
Codec.decode (Name
-> Value a
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     (Maybe a)
     (Maybe a)
forall a. Name -> Value a -> Object (Maybe a)
optional Name
k Value a
c)
        case Maybe a
m of
            Maybe a
Nothing ->
                ExceptT String Identity a
-> StateT [Member Value] (ExceptT String Identity) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift
                    (ExceptT String Identity a
 -> StateT [Member Value] (ExceptT String Identity) a)
-> (String -> ExceptT String Identity a)
-> String
-> StateT [Member Value] (ExceptT String Identity) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String Identity a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Trans.throwE
                    (String -> StateT [Member Value] (ExceptT String Identity) a)
-> String -> StateT [Member Value] (ExceptT String Identity) a
forall a b. (a -> b) -> a -> b
$ String
"missing required member: "
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
k
            Just a
x -> a -> StateT [Member Value] (ExceptT String Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    , encode :: a -> WriterT [Member Value] Identity a
Codec.encode = \a
x -> do
        WriterT [Member Value] Identity (Maybe a)
-> WriterT [Member Value] Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (WriterT [Member Value] Identity (Maybe a)
 -> WriterT [Member Value] Identity ())
-> (Maybe a -> WriterT [Member Value] Identity (Maybe a))
-> Maybe a
-> WriterT [Member Value] Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codec
  (StateT [Member Value] (ExceptT String Identity))
  (WriterT [Member Value] Identity)
  [(Name, Bool, Schema)]
  (Maybe a)
  (Maybe a)
-> Maybe a -> WriterT [Member Value] Identity (Maybe a)
forall (r :: * -> *) (w :: * -> *) s i o.
Codec r w s i o -> i -> w o
Codec.encode (Name
-> Value a
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     (Maybe a)
     (Maybe a)
forall a. Name -> Value a -> Object (Maybe a)
optional Name
k Value a
c) (Maybe a -> WriterT [Member Value] Identity ())
-> Maybe a -> WriterT [Member Value] Identity ()
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
        a -> WriterT [Member Value] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    , schema :: [(Name, Bool, Schema)]
Codec.schema = [(Name
k, Bool
True, Value a -> Schema
forall (r :: * -> *) (w :: * -> *) s i o. Codec r w s i o -> s
Codec.schema Value a
c)]
    }

optional :: Name.Name -> Codec.Value a -> Object (Maybe a)
optional :: Name -> Value a -> Object (Maybe a)
optional Name
k Value a
c = Codec :: forall (r :: * -> *) (w :: * -> *) s i o.
r o -> (i -> w o) -> s -> Codec r w s i o
Codec.Codec
    { decode :: StateT [Member Value] (ExceptT String Identity) (Maybe a)
Codec.decode = do
        [Member Value]
xs <- StateT [Member Value] (ExceptT String Identity) [Member Value]
forall (m :: * -> *) s. Monad m => StateT s m s
Trans.get
        case (Member Value -> Bool)
-> [Member Value] -> ([Member Value], [Member Value])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (\(Member.Member Name
j Value
_) -> Name
j Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
k) [Member Value]
xs of
            (Member.Member Name
_ Value
x : [Member Value]
_, [Member Value]
ys) -> case Value a -> Value -> Either String a
forall a. Value a -> Value -> Either String a
Codec.decodeWith Value a
c Value
x of
                Left String
y -> ExceptT String Identity (Maybe a)
-> StateT [Member Value] (ExceptT String Identity) (Maybe a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (ExceptT String Identity (Maybe a)
 -> StateT [Member Value] (ExceptT String Identity) (Maybe a))
-> ExceptT String Identity (Maybe a)
-> StateT [Member Value] (ExceptT String Identity) (Maybe a)
forall a b. (a -> b) -> a -> b
$ String -> ExceptT String Identity (Maybe a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Trans.throwE String
y
                Right a
y -> do
                    [Member Value]
-> StateT [Member Value] (ExceptT String Identity) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
Trans.put [Member Value]
ys
                    Maybe a
-> StateT [Member Value] (ExceptT String Identity) (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a
 -> StateT [Member Value] (ExceptT String Identity) (Maybe a))
-> Maybe a
-> StateT [Member Value] (ExceptT String Identity) (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
y
            ([Member Value], [Member Value])
_ -> Maybe a
-> StateT [Member Value] (ExceptT String Identity) (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    , encode :: Maybe a -> WriterT [Member Value] Identity (Maybe a)
Codec.encode = \Maybe a
x -> do
        case Maybe a
x of
            Maybe a
Nothing -> () -> WriterT [Member Value] Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just a
y -> [Member Value] -> WriterT [Member Value] Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Trans.tell [Name -> Value -> Member Value
forall value. Name -> value -> Member value
Member.Member Name
k (Value -> Member Value) -> Value -> Member Value
forall a b. (a -> b) -> a -> b
$ Value a -> a -> Value
forall a. Value a -> a -> Value
Codec.encodeWith Value a
c a
y]
        Maybe a -> WriterT [Member Value] Identity (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
x
    , schema :: [(Name, Bool, Schema)]
Codec.schema = [(Name
k, Bool
False, Value a -> Schema
forall (r :: * -> *) (w :: * -> *) s i o. Codec r w s i o -> s
Codec.schema Value a
c)]
    }

tagged :: String -> Codec.Value a -> Codec.Value a
tagged :: String -> Value a -> Value a
tagged String
t Value a
c =
    (((), a) -> a)
-> (a -> ((), a))
-> Codec
     (ReaderT Value (ExceptT String Identity))
     (MaybeT (StateT Value Identity))
     Schema
     ((), a)
     ((), a)
-> Value a
forall (r :: * -> *) (w :: * -> *) a b s.
(Functor r, Functor w) =>
(a -> b) -> (b -> a) -> Codec r w s a a -> Codec r w s b b
Codec.map ((), a) -> a
forall a b. (a, b) -> b
snd ((,) ())
        (Codec
   (ReaderT Value (ExceptT String Identity))
   (MaybeT (StateT Value Identity))
   Schema
   ((), a)
   ((), a)
 -> Value a)
-> (Object ((), a)
    -> Codec
         (ReaderT Value (ExceptT String Identity))
         (MaybeT (StateT Value Identity))
         Schema
         ((), a)
         ((), a))
-> Object ((), a)
-> Value a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permission
-> Object ((), a)
-> Codec
     (ReaderT Value (ExceptT String Identity))
     (MaybeT (StateT Value Identity))
     Schema
     ((), a)
     ((), a)
forall a. Permission -> Object a -> Value a
fromObjectCodec Permission
Permission.Forbid
        (Object ((), a) -> Value a) -> Object ((), a) -> Value a
forall a b. (a -> b) -> a -> b
$ (,)
        (() -> a -> ((), a))
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     ((), a)
     ()
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     ((), a)
     (a -> ((), a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((), a) -> ())
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     ()
     ()
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     ((), a)
     ()
forall i f (r :: * -> *) (w :: * -> *) s o.
(i -> f) -> Codec r w s f o -> Codec r w s i o
Codec.project
                ((), a) -> ()
forall a b. (a, b) -> a
fst
                (Name
-> Value ()
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     ()
     ()
forall a. Name -> Value a -> Object a
required
                    (String -> Name
Name.fromString (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
String.fromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
"type")
                    (Value -> Value ()
Codec.literalCodec
                    (Value -> Value ()) -> (Text -> Value) -> Text -> Value ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Value
Value.String
                    (String -> Value) -> (Text -> String) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
String.fromText
                    (Text -> Value ()) -> Text -> Value ()
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
t
                    )
                )
        Codec
  (StateT [Member Value] (ExceptT String Identity))
  (WriterT [Member Value] Identity)
  [(Name, Bool, Schema)]
  ((), a)
  (a -> ((), a))
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     ((), a)
     a
-> Object ((), a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (((), a) -> a)
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     a
     a
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     ((), a)
     a
forall i f (r :: * -> *) (w :: * -> *) s o.
(i -> f) -> Codec r w s f o -> Codec r w s i o
Codec.project
                ((), a) -> a
forall a b. (a, b) -> b
snd
                (Name
-> Value a
-> Codec
     (StateT [Member Value] (ExceptT String Identity))
     (WriterT [Member Value] Identity)
     [(Name, Bool, Schema)]
     a
     a
forall a. Name -> Value a -> Object a
required
                    (String -> Name
Name.fromString (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
String.fromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
"value")
                    Value a
c
                )