{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE ConstraintKinds #-}
module Data.Aeson.Config.FromValue (
  FromValue(..)
, Parser
, Result
, decodeValue

, Generic
, GenericDecode
, genericFromValue
, Options(..)
, genericFromValueWith

, typeMismatch
, withObject
, withText
, withString
, withArray
, withNumber
, withBool

, parseArray
, traverseObject

, (.:)
, (.:?)

, Key
, Value(..)
, Object
, Array
) where

import           Imports

import           GHC.Generics

import           Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as Map
import qualified Data.Vector as V
import           Data.Aeson.Config.Key (Key)
import qualified Data.Aeson.Config.Key as Key
import qualified Data.Aeson.Config.KeyMap as KeyMap

import           Data.Aeson.Types (FromJSON(..))

import           Data.Aeson.Config.Util
import           Data.Aeson.Config.Parser

type Result a = Either String (a, [String])

decodeValue :: FromValue a => Value -> Result a
decodeValue :: Value -> Result a
decodeValue = (Value -> Parser a) -> Value -> Result a
forall a.
(Value -> Parser a) -> Value -> Either String (a, [String])
runParser Value -> Parser a
forall a. FromValue a => Value -> Parser a
fromValue

(.:) :: FromValue a => Object -> Key -> Parser a
.: :: Object -> Key -> Parser a
(.:) = (Value -> Parser a) -> Object -> Key -> Parser a
forall a. (Value -> Parser a) -> Object -> Key -> Parser a
explicitParseField Value -> Parser a
forall a. FromValue a => Value -> Parser a
fromValue

(.:?) :: FromValue a => Object -> Key -> Parser (Maybe a)
.:? :: Object -> Key -> Parser (Maybe a)
(.:?) = (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
forall a. (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
explicitParseFieldMaybe Value -> Parser a
forall a. FromValue a => Value -> Parser a
fromValue

class FromValue a where
  fromValue :: Value -> Parser a
  default fromValue :: forall d m. (Generic a, Rep a ~ D1 d m, Datatype d, GenericDecode (Rep a)) => Value -> Parser a
  fromValue = Value -> Parser a
forall a (d :: Meta) (m :: * -> *).
(Generic a, Rep a ~ D1 d m, Datatype d, GenericDecode (Rep a)) =>
Value -> Parser a
genericFromValue

genericFromValue :: forall a d m. (Generic a, Rep a ~ D1 d m, Datatype d, GenericDecode (Rep a)) => Value -> Parser a
genericFromValue :: Value -> Parser a
genericFromValue = Options -> Value -> Parser a
forall a.
(Generic a, GenericDecode (Rep a)) =>
Options -> Value -> Parser a
genericFromValueWith ((String -> String) -> Options
Options ((String -> String) -> Options) -> (String -> String) -> Options
forall a b. (a -> b) -> a -> b
$ String -> String -> String
hyphenize String
name)
  where
    name :: String
    name :: String
name = M1 D d m Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName (forall p. M1 D d m p
forall a. HasCallStack => a
undefined :: D1 d m p)

instance FromValue Bool where
  fromValue :: Value -> Parser Bool
fromValue = Parser Bool -> Parser Bool
forall a. Parser a -> Parser a
liftParser (Parser Bool -> Parser Bool)
-> (Value -> Parser Bool) -> Value -> Parser Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Bool
forall a. FromJSON a => Value -> Parser a
parseJSON

instance FromValue Int where
  fromValue :: Value -> Parser Int
fromValue = Parser Int -> Parser Int
forall a. Parser a -> Parser a
liftParser (Parser Int -> Parser Int)
-> (Value -> Parser Int) -> Value -> Parser Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON

instance FromValue Text where
  fromValue :: Value -> Parser Text
fromValue = Parser Text -> Parser Text
forall a. Parser a -> Parser a
liftParser (Parser Text -> Parser Text)
-> (Value -> Parser Text) -> Value -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON

instance {-# OVERLAPPING #-} FromValue String where
  fromValue :: Value -> Parser String
fromValue = Parser String -> Parser String
forall a. Parser a -> Parser a
liftParser (Parser String -> Parser String)
-> (Value -> Parser String) -> Value -> Parser String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser String
forall a. FromJSON a => Value -> Parser a
parseJSON

instance FromValue a => FromValue (Maybe a) where
  fromValue :: Value -> Parser (Maybe a)
fromValue Value
value = Parser (Maybe Value) -> Parser (Maybe Value)
forall a. Parser a -> Parser a
liftParser (Value -> Parser (Maybe Value)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value) Parser (Maybe Value)
-> (Maybe Value -> Parser (Maybe a)) -> Parser (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser a) -> Maybe Value -> Parser (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser a
forall a. FromValue a => Value -> Parser a
fromValue

instance FromValue a => FromValue [a] where
  fromValue :: Value -> Parser [a]
fromValue = (Array -> Parser [a]) -> Value -> Parser [a]
forall a. (Array -> Parser a) -> Value -> Parser a
withArray ((Value -> Parser a) -> Array -> Parser [a]
forall a. (Value -> Parser a) -> Array -> Parser [a]
parseArray Value -> Parser a
forall a. FromValue a => Value -> Parser a
fromValue)

parseArray :: (Value -> Parser a) -> Array -> Parser [a]
parseArray :: (Value -> Parser a) -> Array -> Parser [a]
parseArray Value -> Parser a
f = (Int -> Value -> Parser a) -> [Int] -> [Value] -> Parser [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ((Value -> Parser a) -> Int -> Value -> Parser a
forall a. (Value -> Parser a) -> Int -> Value -> Parser a
parseIndexed Value -> Parser a
f) [Int
0..] ([Value] -> Parser [a])
-> (Array -> [Value]) -> Array -> Parser [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> [Value]
forall a. Vector a -> [a]
V.toList
  where
    parseIndexed :: (Value -> Parser a) -> Int -> Value -> Parser a
    parseIndexed :: (Value -> Parser a) -> Int -> Value -> Parser a
parseIndexed Value -> Parser a
p Int
n Value
value = Value -> Parser a
p Value
value Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
<?> Int -> JSONPathElement
Index Int
n

instance FromValue a => FromValue (Map String a) where
  fromValue :: Value -> Parser (Map String a)
fromValue = (Object -> Parser (Map String a)) -> Value -> Parser (Map String a)
forall a. (Object -> Parser a) -> Value -> Parser a
withObject ((Object -> Parser (Map String a))
 -> Value -> Parser (Map String a))
-> (Object -> Parser (Map String a))
-> Value
-> Parser (Map String a)
forall a b. (a -> b) -> a -> b
$ \ Object
o -> do
    [(Key, a)]
xs <- (Value -> Parser a) -> Object -> Parser [(Key, a)]
forall a. (Value -> Parser a) -> Object -> Parser [(Key, a)]
traverseObject Value -> Parser a
forall a. FromValue a => Value -> Parser a
fromValue Object
o
    Map String a -> Parser (Map String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map String a -> Parser (Map String a))
-> Map String a -> Parser (Map String a)
forall a b. (a -> b) -> a -> b
$ [(String, a)] -> Map String a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((Key, a) -> (String, a)) -> [(Key, a)] -> [(String, a)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> String) -> (Key, a) -> (String, a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Key -> String
Key.toString) [(Key, a)]
xs)

traverseObject :: (Value -> Parser a) -> Object -> Parser [(Key, a)]
traverseObject :: (Value -> Parser a) -> Object -> Parser [(Key, a)]
traverseObject Value -> Parser a
f Object
o = do
  [(Key, Value)]
-> ((Key, Value) -> Parser (Key, a)) -> Parser [(Key, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o) (((Key, Value) -> Parser (Key, a)) -> Parser [(Key, a)])
-> ((Key, Value) -> Parser (Key, a)) -> Parser [(Key, a)]
forall a b. (a -> b) -> a -> b
$ \ (Key
name, Value
value) ->
    (,) Key
name (a -> (Key, a)) -> Parser a -> Parser (Key, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
f Value
value Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
name

instance (FromValue a, FromValue b) => FromValue (a, b) where
  fromValue :: Value -> Parser (a, b)
fromValue Value
v = (,) (a -> b -> (a, b)) -> Parser a -> Parser (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromValue a => Value -> Parser a
fromValue Value
v Parser (b -> (a, b)) -> Parser b -> Parser (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser b
forall a. FromValue a => Value -> Parser a
fromValue Value
v

instance (FromValue a, FromValue b) => FromValue (Either a b) where
  fromValue :: Value -> Parser (Either a b)
fromValue Value
v = a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Parser a -> Parser (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromValue a => Value -> Parser a
fromValue Value
v Parser (Either a b) -> Parser (Either a b) -> Parser (Either a b)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Parser b -> Parser (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser b
forall a. FromValue a => Value -> Parser a
fromValue Value
v

data Options = Options {
  Options -> String -> String
optionsRecordSelectorModifier :: String -> String
}

genericFromValueWith :: (Generic a, GenericDecode (Rep a)) => Options -> Value -> Parser a
genericFromValueWith :: Options -> Value -> Parser a
genericFromValueWith Options
opts = (Rep a Any -> a) -> Parser (Rep a Any) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Parser (Rep a Any) -> Parser a)
-> (Value -> Parser (Rep a Any)) -> Value -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Value -> Parser (Rep a Any)
forall (f :: * -> *) p.
GenericDecode f =>
Options -> Value -> Parser (f p)
genericDecode  Options
opts

class GenericDecode f where
  genericDecode :: Options -> Value -> Parser (f p)

instance (GenericDecode a) => GenericDecode (D1 d a) where
  genericDecode :: Options -> Value -> Parser (D1 d a p)
genericDecode Options
opts = (a p -> D1 d a p) -> Parser (a p) -> Parser (D1 d a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a p -> D1 d a p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Parser (a p) -> Parser (D1 d a p))
-> (Value -> Parser (a p)) -> Value -> Parser (D1 d a p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Value -> Parser (a p)
forall (f :: * -> *) p.
GenericDecode f =>
Options -> Value -> Parser (f p)
genericDecode Options
opts

instance (GenericDecode a) => GenericDecode (C1 c a) where
  genericDecode :: Options -> Value -> Parser (C1 c a p)
genericDecode Options
opts = (a p -> C1 c a p) -> Parser (a p) -> Parser (C1 c a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a p -> C1 c a p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Parser (a p) -> Parser (C1 c a p))
-> (Value -> Parser (a p)) -> Value -> Parser (C1 c a p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Value -> Parser (a p)
forall (f :: * -> *) p.
GenericDecode f =>
Options -> Value -> Parser (f p)
genericDecode Options
opts

instance (GenericDecode a, GenericDecode b) => GenericDecode (a :*: b) where
  genericDecode :: Options -> Value -> Parser ((:*:) a b p)
genericDecode Options
opts Value
o = a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a p -> b p -> (:*:) a b p)
-> Parser (a p) -> Parser (b p -> (:*:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser (a p)
forall (f :: * -> *) p.
GenericDecode f =>
Options -> Value -> Parser (f p)
genericDecode Options
opts Value
o Parser (b p -> (:*:) a b p) -> Parser (b p) -> Parser ((:*:) a b p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Options -> Value -> Parser (b p)
forall (f :: * -> *) p.
GenericDecode f =>
Options -> Value -> Parser (f p)
genericDecode Options
opts Value
o

instance (Selector sel, FromValue a) => GenericDecode (S1 sel (Rec0 a)) where
  genericDecode :: Options -> Value -> Parser (S1 sel (Rec0 a) p)
genericDecode = (Object -> Key -> Parser a)
-> Options -> Value -> Parser (S1 sel (Rec0 a) p)
forall (sel :: Meta) a p.
Selector sel =>
(Object -> Key -> Parser a)
-> Options -> Value -> Parser (S1 sel (Rec0 a) p)
accessFieldWith Object -> Key -> Parser a
forall a. FromValue a => Object -> Key -> Parser a
(.:)

instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (S1 sel (Rec0 (Maybe a))) where
  genericDecode :: Options -> Value -> Parser (S1 sel (Rec0 (Maybe a)) p)
genericDecode = (Object -> Key -> Parser (Maybe a))
-> Options -> Value -> Parser (S1 sel (Rec0 (Maybe a)) p)
forall (sel :: Meta) a p.
Selector sel =>
(Object -> Key -> Parser a)
-> Options -> Value -> Parser (S1 sel (Rec0 a) p)
accessFieldWith Object -> Key -> Parser (Maybe a)
forall a. FromValue a => Object -> Key -> Parser (Maybe a)
(.:?)

accessFieldWith :: forall sel a p. Selector sel => (Object -> Key -> Parser a) -> Options -> Value -> Parser (S1 sel (Rec0 a) p)
accessFieldWith :: (Object -> Key -> Parser a)
-> Options -> Value -> Parser (S1 sel (Rec0 a) p)
accessFieldWith Object -> Key -> Parser a
op Options{String -> String
optionsRecordSelectorModifier :: String -> String
optionsRecordSelectorModifier :: Options -> String -> String
..} Value
v = K1 R a p -> S1 sel (Rec0 a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R a p -> S1 sel (Rec0 a) p)
-> (a -> K1 R a p) -> a -> S1 sel (Rec0 a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 R a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> S1 sel (Rec0 a) p) -> Parser a -> Parser (S1 sel (Rec0 a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object -> Parser a) -> Value -> Parser a
forall a. (Object -> Parser a) -> Value -> Parser a
withObject (Object -> Key -> Parser a
`op` String -> Key
Key.fromString String
label) Value
v
  where
    label :: String
label = String -> String
optionsRecordSelectorModifier (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ S1 sel (Rec0 a) p -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (S1 sel (Rec0 a) p
forall a. HasCallStack => a
undefined :: S1 sel (Rec0 a) p)