{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

module Data.JsonRpc.Generic (
  GFromArrayJSON, genericParseJSONRPC,
  GFieldSetJSON, genericFieldSetParseJSON,

  JsonRpcOptions (..), defaultJsonRpcOptions,

  GToArrayJSON, genericToArrayJSON,
  ) where

import GHC.Generics
import Control.Applicative ((<$>), (<*>), (<*), empty, (<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Writer (Writer, runWriter, tell)
import Control.Monad.Trans.State (StateT, runStateT, get, put)
import Data.Monoid (Endo (..))
import Data.Set ((\\))
import qualified Data.Set as Set
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T
import Data.Aeson.Types
  (FromJSON (..), ToJSON (..), genericParseJSON, Parser, Options (..), Value (..))
import Data.Aeson.Generic.Compat (GFromJSON0)
import Data.Vector (Vector)
import qualified Data.Vector as Vector


class GFromArrayJSON f where
  gFromArrayJSON :: StateT [Value] Parser (f a)

instance GFromArrayJSON U1 where
  gFromArrayJSON :: StateT [Value] Parser (U1 a)
gFromArrayJSON  =  U1 a -> StateT [Value] Parser (U1 a)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1

instance (GFromArrayJSON a, GFromArrayJSON b) => GFromArrayJSON (a :*: b) where
  gFromArrayJSON :: StateT [Value] Parser ((:*:) a b a)
gFromArrayJSON  =  a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> StateT [Value] Parser (a a)
-> StateT [Value] Parser (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Value] Parser (a a)
forall (f :: * -> *) a.
GFromArrayJSON f =>
StateT [Value] Parser (f a)
gFromArrayJSON StateT [Value] Parser (b a -> (:*:) a b a)
-> StateT [Value] Parser (b a)
-> StateT [Value] Parser ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT [Value] Parser (b a)
forall (f :: * -> *) a.
GFromArrayJSON f =>
StateT [Value] Parser (f a)
gFromArrayJSON

instance GFromArrayJSON a => GFromArrayJSON (M1 i c a) where
  gFromArrayJSON :: StateT [Value] Parser (M1 i c a a)
gFromArrayJSON  =  a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 i c a a)
-> StateT [Value] Parser (a a)
-> StateT [Value] Parser (M1 i c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Value] Parser (a a)
forall (f :: * -> *) a.
GFromArrayJSON f =>
StateT [Value] Parser (f a)
gFromArrayJSON

instance FromJSON a => GFromArrayJSON (K1 i a) where
  gFromArrayJSON :: StateT [Value] Parser (K1 i a a)
gFromArrayJSON  =  do
    [Value]
vs'  <-  StateT [Value] Parser [Value]
forall (m :: * -> *) s. Monad m => StateT s m s
get
    a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a)
-> StateT [Value] Parser a -> StateT [Value] Parser (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case [Value]
vs' of
     Value
v:[Value]
vs  ->  (Parser a -> StateT [Value] Parser a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser a -> StateT [Value] Parser a)
-> Parser a -> StateT [Value] Parser a
forall a b. (a -> b) -> a -> b
$ Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)   StateT [Value] Parser a
-> StateT [Value] Parser () -> StateT [Value] Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [Value] -> StateT [Value] Parser ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Value]
vs
     []    ->   Parser a -> StateT [Value] Parser a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser a -> StateT [Value] Parser a)
-> Parser a -> StateT [Value] Parser a
forall a b. (a -> b) -> a -> b
$ Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Null


type FieldName = String
type FieldsW = Writer (Endo [FieldName])

class GFieldSetJSON f where
  gFieldSet :: FieldsW (f a)

instance GFieldSetJSON U1 where
  gFieldSet :: FieldsW (U1 a)
gFieldSet = U1 a -> FieldsW (U1 a)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1

instance (GFieldSetJSON a, GFieldSetJSON b) => GFieldSetJSON (a :*: b) where
  gFieldSet :: FieldsW ((:*:) a b a)
gFieldSet  =  do
    a a
x <- FieldsW (a a)
forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a)
gFieldSet
    b a
y <- FieldsW (b a)
forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a)
gFieldSet
    (:*:) a b a -> FieldsW ((:*:) a b a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a a
x a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b a
y)

instance GFieldSetJSON a => GFieldSetJSON (D1 c a) where
  gFieldSet :: FieldsW (D1 c a a)
gFieldSet  =  do
    a a
x <- FieldsW (a a)
forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a)
gFieldSet
    D1 c a a -> FieldsW (D1 c a a)
forall (m :: * -> *) a. Monad m => a -> m a
return (D1 c a a -> FieldsW (D1 c a a)) -> D1 c a a -> FieldsW (D1 c a a)
forall a b. (a -> b) -> a -> b
$ a a -> D1 c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 a a
x

instance GFieldSetJSON a => GFieldSetJSON (C1 c a) where
  gFieldSet :: FieldsW (C1 c a a)
gFieldSet  =  do
    a a
x  <- FieldsW (a a)
forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a)
gFieldSet
    C1 c a a -> FieldsW (C1 c a a)
forall (m :: * -> *) a. Monad m => a -> m a
return (C1 c a a -> FieldsW (C1 c a a)) -> C1 c a a -> FieldsW (C1 c a a)
forall a b. (a -> b) -> a -> b
$ a a -> C1 c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 a a
x

instance (GFieldSetJSON a, Selector s) => GFieldSetJSON (S1 s a) where
  gFieldSet :: FieldsW (S1 s a a)
gFieldSet  =  do
    a a
x <- FieldsW (a a)
forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a)
gFieldSet
    S1 s a a -> FieldsW (S1 s a a)
forall (a :: * -> *) (s :: Meta) p.
(GFieldSetJSON a, Selector s) =>
S1 s a p -> FieldsW (S1 s a p)
saveQueriedField (S1 s a a -> FieldsW (S1 s a a)) -> S1 s a a -> FieldsW (S1 s a a)
forall a b. (a -> b) -> a -> b
$ a a -> S1 s a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 a a
x

saveQueriedField :: (GFieldSetJSON a, Selector s)
                 => S1 s a p
                 -> FieldsW (S1 s a p)
saveQueriedField :: S1 s a p -> FieldsW (S1 s a p)
saveQueriedField S1 s a p
m1  =  do
  Endo [[Char]] -> WriterT (Endo [[Char]]) Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (([[Char]] -> [[Char]]) -> Endo [[Char]]
forall a. (a -> a) -> Endo a
Endo (S1 s a p -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName S1 s a p
m1 [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:))
  S1 s a p -> FieldsW (S1 s a p)
forall (m :: * -> *) a. Monad m => a -> m a
return S1 s a p
m1

instance GFieldSetJSON (K1 i a) where
  gFieldSet :: FieldsW (K1 i a a)
gFieldSet  =  K1 i a a -> FieldsW (K1 i a a)
forall (m :: * -> *) a. Monad m => a -> m a
return (K1 i a a -> FieldsW (K1 i a a)) -> K1 i a a -> FieldsW (K1 i a a)
forall a b. (a -> b) -> a -> b
$ a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 a
forall a. HasCallStack => a
undefined

genericFieldSetParseJSON :: (Generic a, GFromJSON0 (Rep a), GFieldSetJSON (Rep a))
                         => JsonRpcOptions
                         -> Options
                         -> Value
                         -> Parser a
genericFieldSetParseJSON :: JsonRpcOptions -> Options -> Value -> Parser a
genericFieldSetParseJSON = JsonRpcOptions -> Options -> Value -> Parser a
forall b.
(GFromJSON Zero (Rep b), GFieldSetJSON (Rep b), Generic b) =>
JsonRpcOptions -> Options -> Value -> Parser b
d  where
  d :: JsonRpcOptions -> Options -> Value -> Parser b
d JsonRpcOptions
rpcOpts Options
opts v :: Value
v@(Object Object
m)  =  do
    let (Rep b a
px, Endo [[Char]]
fs)  =  Writer (Endo [[Char]]) (Rep b a) -> (Rep b a, Endo [[Char]])
forall w a. Writer w a -> (a, w)
runWriter Writer (Endo [[Char]]) (Rep b a)
forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a)
gFieldSet
        inv :: Set Text
inv  =  [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList (Object -> [Text]
forall k v. HashMap k v -> [k]
HashMap.keys Object
m) Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
\\
                [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList (([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> [Char] -> [Char]
fieldLabelModifier Options
opts) ([[Char]] -> [Text]) -> [[Char]] -> [Text]
forall a b. (a -> b) -> a -> b
$ Endo [[Char]] -> [[Char]] -> [[Char]]
forall a. Endo a -> a -> a
appEndo Endo [[Char]]
fs [])
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (JsonRpcOptions -> Bool
allowNonExistField JsonRpcOptions
rpcOpts Bool -> Bool -> Bool
|| Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
inv)
      Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> Parser ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"object has illegal field: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
forall a. Show a => a -> [Char]
show (Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
inv))
    b
j  <-  Options -> Value -> Parser b
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts Value
v
    let Rep b Any
_ = b -> Rep b Any
forall a x. Generic a => a -> Rep a x
from b
j Rep b Any -> Rep b Any -> Rep b Any
forall a. a -> a -> a
`asTypeOf` Rep b Any
forall a. Rep b a
px
    b -> Parser b
forall (m :: * -> *) a. Monad m => a -> m a
return b
j
  d JsonRpcOptions
_       Options
opts Value
v             =
    Options -> Value -> Parser b
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts Value
v


genericParseJSONRPC :: (Generic a, GFromJSON0 (Rep a), GFromArrayJSON (Rep a), GFieldSetJSON (Rep a))
                    => JsonRpcOptions -> Options -> Value -> Parser a
genericParseJSONRPC :: JsonRpcOptions -> Options -> Value -> Parser a
genericParseJSONRPC JsonRpcOptions
rpcOpt Options
opt = Value -> Parser a
forall b.
(GFromArrayJSON (Rep b), Generic b, GFromJSON Zero (Rep b),
 GFieldSetJSON (Rep b)) =>
Value -> Parser b
d where
  d :: Value -> Parser b
d (Array Array
vs)      =  do (Rep b Any
a, [Value]
s) <- StateT [Value] Parser (Rep b Any)
-> [Value] -> Parser (Rep b Any, [Value])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT [Value] Parser (Rep b Any)
forall (f :: * -> *) a.
GFromArrayJSON f =>
StateT [Value] Parser (f a)
gFromArrayJSON ([Value] -> Parser (Rep b Any, [Value]))
-> [Value] -> Parser (Rep b Any, [Value])
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
vs
                          Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (JsonRpcOptions -> Bool
allowSpilledArguemnts JsonRpcOptions
rpcOpt Bool -> Bool -> Bool
|| [Value] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
s)
                            Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> Parser ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Too many arguments! Spilled arguments: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Value] -> [Char]
forall a. Show a => a -> [Char]
show [Value]
s)
                          b -> Parser b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Parser b) -> b -> Parser b
forall a b. (a -> b) -> a -> b
$ Rep b Any -> b
forall a x. Generic a => Rep a x -> a
to Rep b Any
a
  d v :: Value
v@(Object Object
_)    =  JsonRpcOptions -> Options -> Value -> Parser b
forall a.
(Generic a, GFromJSON0 (Rep a), GFieldSetJSON (Rep a)) =>
JsonRpcOptions -> Options -> Value -> Parser a
genericFieldSetParseJSON JsonRpcOptions
rpcOpt Options
opt Value
v
  d Value
_               =  Parser b
forall (f :: * -> *) a. Alternative f => f a
empty

data JsonRpcOptions =
  JsonRpcOptions
  { JsonRpcOptions -> Bool
allowSpilledArguemnts  ::  Bool
  , JsonRpcOptions -> Bool
allowNonExistField     ::  Bool
  }

defaultJsonRpcOptions :: JsonRpcOptions
defaultJsonRpcOptions :: JsonRpcOptions
defaultJsonRpcOptions =
  JsonRpcOptions :: Bool -> Bool -> JsonRpcOptions
JsonRpcOptions
  { allowSpilledArguemnts :: Bool
allowSpilledArguemnts  =  Bool
True
  , allowNonExistField :: Bool
allowNonExistField     =  Bool
True
  }


class GToArrayJSON f where
  gToArrayJSON :: f a -> Vector Value

instance GToArrayJSON U1 where
  gToArrayJSON :: U1 a -> Array
gToArrayJSON U1 a
U1 = Array
forall a. Vector a
Vector.empty

instance (GToArrayJSON a, GToArrayJSON b) => GToArrayJSON (a :*: b) where
  gToArrayJSON :: (:*:) a b a -> Array
gToArrayJSON (a a
x :*: b a
y)  =  a a -> Array
forall (f :: * -> *) a. GToArrayJSON f => f a -> Array
gToArrayJSON a a
x Array -> Array -> Array
forall a. Vector a -> Vector a -> Vector a
Vector.++ b a -> Array
forall (f :: * -> *) a. GToArrayJSON f => f a -> Array
gToArrayJSON b a
y

instance GToArrayJSON a => GToArrayJSON (M1 i c a) where
  gToArrayJSON :: M1 i c a a -> Array
gToArrayJSON (M1 a a
x)  =  a a -> Array
forall (f :: * -> *) a. GToArrayJSON f => f a -> Array
gToArrayJSON a a
x

instance ToJSON a => GToArrayJSON (K1 i a) where
  gToArrayJSON :: K1 i a a -> Array
gToArrayJSON (K1 a
x)  =  Value -> Array
forall a. a -> Vector a
Vector.singleton (Value -> Array) -> Value -> Array
forall a b. (a -> b) -> a -> b
$ a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x

genericToArrayJSON :: (Generic a, GToArrayJSON (Rep a))
                   => a -> Value
genericToArrayJSON :: a -> Value
genericToArrayJSON = Array -> Value
Array (Array -> Value) -> (a -> Array) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> Array
forall (f :: * -> *) a. GToArrayJSON f => f a -> Array
gToArrayJSON (Rep a Any -> Array) -> (a -> Rep a Any) -> a -> Array
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from