{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
module Data.Registry.Aeson.Decoder
( module Data.Registry.Aeson.Decoder,
module Data.Registry.Aeson.TH.Decoder,
module Data.Registry.Aeson.TH.ThOptions,
)
where
import Data.Aeson
import Data.Map qualified as M
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.ByteString.Lazy qualified as BL
import Data.List ((\\))
import Data.Registry
import Data.Registry.Aeson.TH.Decoder
import Data.Registry.Aeson.TH.ThOptions
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Vector qualified as Vector
import Protolude as P hiding (Type)
import Prelude (String, show)
newtype Decoder a = Decoder {forall a. Decoder a -> Value -> Either Text a
decodeValue :: Value -> Either Text a}
instance Functor Decoder where
fmap :: forall a b. (a -> b) -> Decoder a -> Decoder b
fmap a -> b
f (Decoder Value -> Either Text a
d) = forall a. (Value -> Either Text a) -> Decoder a
Decoder (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either Text a
d)
instance Applicative Decoder where
pure :: forall a. a -> Decoder a
pure a
a = forall a. (Value -> Either Text a) -> Decoder a
Decoder (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a))
Decoder (a -> b)
f <*> :: forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
<*> Decoder a
a = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
($) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Decoder a -> Decoder b -> Decoder (a, b)
decoderAp Decoder (a -> b)
f Decoder a
a
decoderAp :: Decoder a -> Decoder b -> Decoder (a, b)
decoderAp :: forall a b. Decoder a -> Decoder b -> Decoder (a, b)
decoderAp (Decoder Value -> Either Text a
da) (Decoder Value -> Either Text b
db) = forall a. (Value -> Either Text a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
o :: Value
o@(Array Array
ls) ->
case forall a. [a] -> [a]
reverse (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
ls) of
Value
b : [Value]
as -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
da (Array -> Value
Array forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Value]
as) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
db Value
b
[] -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
da Value
o forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
db Value
o
Value
o -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
da Value
o forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
db Value
o
newtype KeyDecoder a = KeyDecoder {forall a. KeyDecoder a -> Key -> Either Text a
decodeKeyAs :: Key -> Either Text a}
instance Functor KeyDecoder where
fmap :: forall a b. (a -> b) -> KeyDecoder a -> KeyDecoder b
fmap a -> b
f (KeyDecoder Key -> Either Text a
d) = forall a. (Key -> Either Text a) -> KeyDecoder a
KeyDecoder (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Either Text a
d)
decodeByteString :: forall a. (Typeable a) => Decoder a -> BL.ByteString -> Either Text a
decodeByteString :: forall a. Typeable a => Decoder a -> ByteString -> Either Text a
decodeByteString Decoder a
d ByteString
bs =
case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
bs of
Left [Char]
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Cannot parse the string as a Value: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
P.show [Char]
e forall a. Semigroup a => a -> a -> a
<> Text
". The string is: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
P.show ByteString
bs
Right Value
v ->
case forall a. Decoder a -> Value -> Either Text a
decodeValue Decoder a
d Value
v of
Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left Text
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Cannot decode the type '" forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS (forall {k} (a :: k). Typeable a => [Char]
showType @a) forall a. Semigroup a => a -> a -> a
<> Text
"' >> " forall a. Semigroup a => a -> a -> a
<> Text
e
decodeKey :: forall a. (Typeable a) => (Text -> Either Text a) -> Typed (KeyDecoder a)
decodeKey :: forall a.
Typeable a =>
(Text -> Either Text a) -> Typed (KeyDecoder a)
decodeKey Text -> Either Text a
f = forall a. Typeable a => a -> Typed a
fun (forall a. (Text -> Either Text a) -> KeyDecoder a
keyDecoder Text -> Either Text a
f)
keyDecoder :: forall a. (Text -> Either Text a) -> KeyDecoder a
keyDecoder :: forall a. (Text -> Either Text a) -> KeyDecoder a
keyDecoder Text -> Either Text a
f = forall a. (Key -> Either Text a) -> KeyDecoder a
KeyDecoder forall a b. (a -> b) -> a -> b
$ Text -> Either Text a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
jsonDecoder :: forall a. (FromJSON a, Typeable a) => Typed (Decoder a)
jsonDecoder :: forall a. (FromJSON a, Typeable a) => Typed (Decoder a)
jsonDecoder = forall a. Typeable a => a -> Typed a
fun (forall a. FromJSON a => Decoder a
jsonDecoderOf @a)
jsonDecoderOf :: FromJSON a => Decoder a
jsonDecoderOf :: forall a. FromJSON a => Decoder a
jsonDecoderOf = forall a. (Value -> Either Text a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \Value
v ->
case forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
Success a
a -> forall a b. b -> Either a b
Right a
a
Error [Char]
e -> forall a b. a -> Either a b
Left (forall a b. ConvertText a b => a -> b
toS [Char]
e)
decodeMaybeOf :: forall a. (Typeable a) => Typed (Decoder a -> Decoder (Maybe a))
decodeMaybeOf :: forall a. Typeable a => Typed (Decoder a -> Decoder (Maybe a))
decodeMaybeOf = forall a. Typeable a => a -> Typed a
fun (forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder @a)
maybeOfDecoder :: forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder :: forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder (Decoder Value -> Either Text a
d) = forall a. (Value -> Either Text a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
Value
Null -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Value
just -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
d Value
just
decodePairOf :: forall a b. (Typeable a, Typeable b) => Typed (Decoder a -> Decoder b -> Decoder (a, b))
decodePairOf :: forall a b.
(Typeable a, Typeable b) =>
Typed (Decoder a -> Decoder b -> Decoder (a, b))
decodePairOf = forall a. Typeable a => a -> Typed a
fun (forall a b.
(Typeable a, Typeable b) =>
Decoder a -> Decoder b -> Decoder (a, b)
pairOfDecoder @a @b)
pairOfDecoder :: forall a b. (Typeable a, Typeable b) => Decoder a -> Decoder b -> Decoder (a, b)
pairOfDecoder :: forall a b.
(Typeable a, Typeable b) =>
Decoder a -> Decoder b -> Decoder (a, b)
pairOfDecoder (Decoder Value -> Either Text a
a) (Decoder Value -> Either Text b
b) = forall a. (Value -> Either Text a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
Array [Item Array
oa, Item Array
ob] -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
a Item Array
oa forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
b Item Array
ob
Value
_ -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ [Char]
"not a pair of " forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @a forall a. Semigroup a => a -> a -> a
<> [Char]
"," forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @b
decodeTripleOf :: forall a b c. (Typeable a, Typeable b, Typeable c) => Typed (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
decodeTripleOf :: forall a b c.
(Typeable a, Typeable b, Typeable c) =>
Typed (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
decodeTripleOf = forall a. Typeable a => a -> Typed a
fun (forall a b c.
(Typeable a, Typeable b, Typeable c) =>
Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)
tripleOfDecoder @a @b @c)
tripleOfDecoder :: forall a b c. (Typeable a, Typeable b, Typeable c) => Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)
tripleOfDecoder :: forall a b c.
(Typeable a, Typeable b, Typeable c) =>
Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)
tripleOfDecoder (Decoder Value -> Either Text a
a) (Decoder Value -> Either Text b
b) (Decoder Value -> Either Text c
c) = forall a. (Value -> Either Text a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
Array [Item Array
oa, Item Array
ob, Item Array
oc] -> (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
a Item Array
oa forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
b Item Array
ob forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text c
c Item Array
oc
Value
_ -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ [Char]
"not a triple of " forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @a forall a. Semigroup a => a -> a -> a
<> [Char]
"," forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @b forall a. Semigroup a => a -> a -> a
<> [Char]
"," forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @c
decodeListOf :: forall a. (Typeable a) => Typed (Decoder a -> Decoder [a])
decodeListOf :: forall a. Typeable a => Typed (Decoder a -> Decoder [a])
decodeListOf = forall a. Typeable a => a -> Typed a
fun (forall a. Typeable a => Decoder a -> Decoder [a]
listOfDecoder @a)
listOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder [a]
listOfDecoder :: forall a. Typeable a => Decoder a -> Decoder [a]
listOfDecoder (Decoder Value -> Either Text a
a) = forall a. (Value -> Either Text a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
Array Array
vs -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
vs) Value -> Either Text a
a
Value
_ -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ [Char]
"not a list of " forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @a
decodeMapOf :: forall a b. (Typeable a, Ord a, Typeable b) => Typed (KeyDecoder a -> Decoder b -> Decoder (Map a b))
decodeMapOf :: forall a b.
(Typeable a, Ord a, Typeable b) =>
Typed (KeyDecoder a -> Decoder b -> Decoder (Map a b))
decodeMapOf = forall a. Typeable a => a -> Typed a
fun (forall a b.
(Typeable a, Ord a, Typeable b) =>
KeyDecoder a -> Decoder b -> Decoder (Map a b)
mapOfDecoder @a @b)
mapOfDecoder :: forall a b. (Typeable a, Ord a, Typeable b) => KeyDecoder a -> Decoder b -> Decoder (Map a b)
mapOfDecoder :: forall a b.
(Typeable a, Ord a, Typeable b) =>
KeyDecoder a -> Decoder b -> Decoder (Map a b)
mapOfDecoder (KeyDecoder Key -> Either Text a
a) (Decoder Value -> Either Text b
b) = forall a. (Value -> Either Text a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
Object Object
vs -> forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall v. KeyMap v -> [(Key, v)]
KM.toList Object
vs) (\(Key
k, Value
v) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Either Text a
a Key
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
b Value
v)
Value
_ -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ [Char]
"not a map of " forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @a forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @b
decodeNonEmptyOf :: forall a. (Typeable a) => Typed (Decoder a -> Decoder (NonEmpty a))
decodeNonEmptyOf :: forall a. Typeable a => Typed (Decoder a -> Decoder (NonEmpty a))
decodeNonEmptyOf = forall a. Typeable a => a -> Typed a
fun (forall a. Typeable a => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder @a)
nonEmptyOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder :: forall a. Typeable a => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder (Decoder Value -> Either Text a
a) = forall a. (Value -> Either Text a) -> Decoder a
Decoder forall a b. (a -> b) -> a -> b
$ \case
Array Array
values ->
case forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
values of
[] -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ [Char]
"expected a NonEmpty of " forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @a
Value
o : [Value]
os -> forall a. a -> [a] -> NonEmpty a
(:|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
a Value
o forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
os Value -> Either Text a
a
Value
_ -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ [Char]
"not a list of " forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @a
showType :: forall a. (Typeable a) => String
showType :: forall {k} (a :: k). Typeable a => [Char]
showType = forall a b. (Show a, StringConv [Char] b) => a -> b
P.show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))
defaultDecoderOptions :: Registry _ _
defaultDecoderOptions :: Registry
'[]
'[ConstructorsDecoder, KeyDecoder Text, KeyDecoder [Char], Options]
defaultDecoderOptions =
forall a. Typeable a => a -> Typed a
fun ConstructorsDecoder
defaultConstructorsDecoder
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a. Typeable a => a -> Typed a
fun KeyDecoder Text
textKeyDecoder
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a. Typeable a => a -> Typed a
fun KeyDecoder [Char]
stringKeyDecoder
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a. (Typeable a, Show a) => a -> Typed a
val Options
defaultOptions
textKeyDecoder :: KeyDecoder Text
textKeyDecoder :: KeyDecoder Text
textKeyDecoder = forall a. (Text -> Either Text a) -> KeyDecoder a
keyDecoder forall a b. b -> Either a b
Right
stringKeyDecoder :: KeyDecoder String
stringKeyDecoder :: KeyDecoder [Char]
stringKeyDecoder = forall a. (Text -> Either Text a) -> KeyDecoder a
keyDecoder (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS)
decodeFieldValue :: Decoder a -> Text -> Text -> (Maybe FieldDef, Value) -> Either Text a
decodeFieldValue :: forall a.
Decoder a
-> Text -> Text -> (Maybe FieldDef, Value) -> Either Text a
decodeFieldValue Decoder a
d Text
typeName Text
constructorName (Maybe FieldDef
field, Value
v) =
case forall a. Decoder a -> Value -> Either Text a
decodeValue Decoder a
d Value
v of
Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left Text
e -> do
let constructor :: Text
constructor = if Text
typeName forall a. Eq a => a -> a -> Bool
== Text
constructorName then Text
"" else Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
constructorName forall a. Semigroup a => a -> a -> a
<> Text
") "
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
constructor (\(Text
fn, Text
ft) -> Text
constructor forall a. Semigroup a => a -> a -> a
<> Text
"'" forall a. Semigroup a => a -> a -> a
<> Text
fn forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
ft forall a. Semigroup a => a -> a -> a
<> Text
"' >> ") Maybe FieldDef
field forall a. Semigroup a => a -> a -> a
<> Text
e
data ConstructorDef = ConstructorDef
{
ConstructorDef -> Text
constructorDefName :: Text,
ConstructorDef -> Text
constructorDefModifiedName :: Text,
ConstructorDef -> [Text]
constructorDefFields :: [Text],
ConstructorDef -> [Text]
constructorDefModifiedFieldNames :: [Text],
ConstructorDef -> [Text]
constructorDefFieldsTypes :: [Text]
}
deriving (ConstructorDef -> ConstructorDef -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstructorDef -> ConstructorDef -> Bool
$c/= :: ConstructorDef -> ConstructorDef -> Bool
== :: ConstructorDef -> ConstructorDef -> Bool
$c== :: ConstructorDef -> ConstructorDef -> Bool
Eq)
instance Show ConstructorDef where
show :: ConstructorDef -> [Char]
show (ConstructorDef Text
n Text
_ [] [Text]
_ [Text]
fts) =
forall a b. ConvertText a b => a -> b
toS (Text
n forall a. Semigroup a => a -> a -> a
<> Text
" [" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
fts) forall a. Semigroup a => a -> a -> a
<> [Char]
"]"
show (ConstructorDef Text
n Text
_ [Text]
fns [Text]
_ [Text]
fts) =
forall a b. ConvertText a b => a -> b
toS (Text
n forall a. Semigroup a => a -> a -> a
<> Text
" {" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((\(Text
fn, Text
ft) -> Text
fn forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
ft) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fns [Text]
fts)) forall a. Semigroup a => a -> a -> a
<> [Char]
"}"
makeConstructorDef :: Text -> [Text] -> [Text] -> ConstructorDef
makeConstructorDef :: Text -> [Text] -> [Text] -> ConstructorDef
makeConstructorDef Text
constructorName [Text]
fieldNames = Text -> Text -> [Text] -> [Text] -> [Text] -> ConstructorDef
ConstructorDef Text
constructorName Text
constructorName [Text]
fieldNames [Text]
fieldNames
data ToConstructor = ToConstructor
{
ToConstructor -> Text
toConstructorName :: Text,
ToConstructor -> [(Maybe FieldDef, Value)]
toConstructorValues :: [(Maybe FieldDef, Value)]
}
deriving (ToConstructor -> ToConstructor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ToConstructor -> ToConstructor -> Bool
$c/= :: ToConstructor -> ToConstructor -> Bool
== :: ToConstructor -> ToConstructor -> Bool
$c== :: ToConstructor -> ToConstructor -> Bool
Eq)
instance Show ToConstructor where
show :: ToConstructor -> [Char]
show (ToConstructor Text
constructorName [(Maybe FieldDef, Value)]
values) =
forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ Text
constructorName forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a. ToJSON a => a -> Text
encodeAsText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe FieldDef, Value)]
values) forall a. Semigroup a => a -> a -> a
<> Text
")"
decodeFromDefinitions :: Options -> ConstructorsDecoder -> [ConstructorDef] -> Value -> (ToConstructor -> Either Text a) -> Either Text a
decodeFromDefinitions :: forall a.
Options
-> ConstructorsDecoder
-> [ConstructorDef]
-> Value
-> (ToConstructor -> Either Text a)
-> Either Text a
decodeFromDefinitions Options
options ConstructorsDecoder
constructorsDecoder [ConstructorDef]
constructorDefs Value
value ToConstructor -> Either Text a
build = do
let toConstructors :: Either Text [Either Text a]
toConstructors = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ToConstructor -> Either Text a
build forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorsDecoder
-> Options
-> [ConstructorDef]
-> Value
-> Either Text [ToConstructor]
decodeConstructors ConstructorsDecoder
constructorsDecoder Options
options [ConstructorDef]
constructorDefs Value
value
case Either Text [Either Text a]
toConstructors of
Left Text
e -> forall a b. a -> Either a b
Left Text
e
Right [Either Text a]
es -> forall c. [Either Text c] -> Either Text c
foldEither [Either Text a]
es
newtype ConstructorsDecoder = ConstructorsDecoder
{ ConstructorsDecoder
-> Options
-> [ConstructorDef]
-> Value
-> Either Text [ToConstructor]
decodeConstructors :: Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]
}
defaultConstructorsDecoder :: ConstructorsDecoder
defaultConstructorsDecoder :: ConstructorsDecoder
defaultConstructorsDecoder = (Options
-> [ConstructorDef] -> Value -> Either Text [ToConstructor])
-> ConstructorsDecoder
ConstructorsDecoder Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]
makeToConstructors
makeToConstructors :: Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]
makeToConstructors :: Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]
makeToConstructors Options
options [ConstructorDef]
cs Value
value = do
let constructors :: [ConstructorDef]
constructors = Options -> ConstructorDef -> ConstructorDef
applyOptions Options
options forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
cs
let isEnumeration :: Bool
isEnumeration = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorDef -> [Text]
constructorDefFieldsTypes) [ConstructorDef]
constructors
if Bool
isEnumeration Bool -> Bool -> Bool
&& Options -> Bool
allNullaryToStringTag Options
options
then case Value
value of
String Text
name ->
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Text
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorDef -> Text
constructorDefModifiedName) [ConstructorDef]
constructors of
Just ConstructorDef
c -> forall (f :: * -> *) (g :: * -> *) a.
(Applicative f, Applicative g) =>
a -> f (g a)
purer forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor (ConstructorDef -> Text
constructorDefName ConstructorDef
c) []
Maybe ConstructorDef
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected one of " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (ConstructorDef -> Text
constructorDefModifiedName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
constructors) forall a. Semigroup a => a -> a -> a
<> Text
". Got: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
P.show Text
name
Value
other -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected one of " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (ConstructorDef -> Text
constructorDefName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
constructors) forall a. Semigroup a => a -> a -> a
<> Text
". Got: " forall a. Semigroup a => a -> a -> a
<> forall a. ToJSON a => a -> Text
encodeAsText Value
other
else case [ConstructorDef]
constructors of
[Item [ConstructorDef]
c]
| Bool -> Bool
not (Options -> Bool
tagSingleConstructors Options
options) Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool
isEnumeration Bool -> Bool -> Bool
&& Bool -> Bool
not (Options -> Bool
allNullaryToStringTag Options
options)) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options Item [ConstructorDef]
c Value
value
[ConstructorDef]
_ -> do
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Options -> [ConstructorDef] -> Value -> Maybe Text
checkSumEncoding Options
options [ConstructorDef]
constructors Value
value
case Options -> SumEncoding
sumEncoding Options
options of
TaggedObject (forall a b. ConvertText a b => a -> b
toS -> Text
tagFieldName) (forall a b. ConvertText a b => a -> b
toS -> Text
contentsFieldName) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options
-> Text
-> Text
-> [ConstructorDef]
-> Value
-> Either Text ToConstructor
makeTaggedObject Options
options Text
tagFieldName Text
contentsFieldName [ConstructorDef]
constructors Value
value
SumEncoding
UntaggedValue ->
Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]
makeUntaggedValue Options
options [ConstructorDef]
constructors Value
value
SumEncoding
ObjectWithSingleField ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> [ConstructorDef] -> Value -> Either Text ToConstructor
makeObjectWithSingleField Options
options [ConstructorDef]
constructors Value
value
SumEncoding
TwoElemArray ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> [ConstructorDef] -> Value -> Either Text ToConstructor
makeTwoElemArray Options
options [ConstructorDef]
constructors Value
value
makeTaggedObject :: Options -> Text -> Text -> [ConstructorDef] -> Value -> Either Text ToConstructor
makeTaggedObject :: Options
-> Text
-> Text
-> [ConstructorDef]
-> Value
-> Either Text ToConstructor
makeTaggedObject Options
options Text
tagFieldName Text
contentsFieldName [ConstructorDef]
constructors Value
value =
[ConstructorDef]
-> (ConstructorDef -> Either Text ToConstructor)
-> Either Text ToConstructor
tryConstructors [ConstructorDef]
constructors forall a b. (a -> b) -> a -> b
$ \c :: ConstructorDef
c@(ConstructorDef Text
constructorName Text
modifiedConstructorName [Text]
fieldNames [Text]
modifiedFieldNames [Text]
fieldTypes) ->
case Value
value of
Object Object
vs ->
case forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
tagFieldName) Object
vs of
Just Value
tagValue ->
case ([Text]
modifiedFieldNames, [Text]
fieldNames, [Text]
fieldTypes) of
([], [], [])
| Value
tagValue forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName []
([], [], [Item [Text]
_])
| Value
tagValue forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName ->
case forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
contentsFieldName) Object
vs of
Just Value
fieldValue -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(forall a. Maybe a
Nothing, Value
fieldValue)]
Maybe Value
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"field " forall a. Semigroup a => a -> a -> a
<> Text
contentsFieldName forall a. Semigroup a => a -> a -> a
<> Text
" not found"
([Item [Text]
modifiedFieldName], [Item [Text]
fieldName], [Item [Text]
fieldType])
| Value
tagValue forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName ->
case forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Item [Text]
modifiedFieldName) Object
vs of
Just Value
fieldValue -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(forall a. a -> Maybe a
Just (Item [Text]
fieldName, Item [Text]
fieldType), Value
fieldValue)]
Maybe Value
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"field " forall a. Semigroup a => a -> a -> a
<> Item [Text]
modifiedFieldName forall a. Semigroup a => a -> a -> a
<> Text
" not found"
([Text]
_, [Text]
_, [Text]
_)
| Value
tagValue forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName Bool -> Bool -> Bool
&& Options -> Bool
omitNothingFields Options
options Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
modifiedFieldNames) (Key -> Text
K.toText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. KeyMap v -> [Key]
KM.keys Object
vs) -> do
let rest :: Object
rest = forall v. [(Key, v)] -> KeyMap v
KM.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Text
tagFieldName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [(Key, v)]
KM.toList Object
vs
Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c (Object -> Value
Object Object
rest)
([Text]
_, Text
_ : [Text]
_, [Text]
_)
| Value
tagValue forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName ->
Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
value
([Text]
_, [Text]
_, [Text]
_)
| Value
tagValue forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== Text
contentsFieldName) (Key -> Text
K.toText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. KeyMap v -> [Key]
KM.keys Object
vs) ->
case forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
contentsFieldName) Object
vs of
Just Value
contentsValue -> Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
contentsValue
Maybe Value
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"contents field not found '" forall a. Semigroup a => a -> a -> a
<> Text
contentsFieldName forall a. Semigroup a => a -> a -> a
<> Text
"'"
([Text]
_, [Text]
_, [Text]
_) ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
P.show ConstructorDef
c
Maybe Value
Nothing ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
P.show ConstructorDef
c forall a. Semigroup a => a -> a -> a
<> Text
". tag field not found: " forall a. Semigroup a => a -> a -> a
<> Text
tagFieldName
Value
_ ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
P.show ConstructorDef
c forall a. Semigroup a => a -> a -> a
<> Text
". Expected an Object"
makeUntaggedValue :: Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]
makeUntaggedValue :: Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]
makeUntaggedValue Options
options [ConstructorDef]
constructors Value
value =
case forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ (\ConstructorDef
c -> Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
value) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
constructors of
(Text
e : [Text]
_, []) -> forall a b. a -> Either a b
Left Text
e
([], []) -> forall a b. a -> Either a b
Left Text
"no constructors"
([Text]
_, [ToConstructor]
rs) -> forall a b. b -> Either a b
Right [ToConstructor]
rs
makeObjectWithSingleField :: Options -> [ConstructorDef] -> Value -> Either Text ToConstructor
makeObjectWithSingleField :: Options -> [ConstructorDef] -> Value -> Either Text ToConstructor
makeObjectWithSingleField Options
options [ConstructorDef]
constructors Value
value =
[ConstructorDef]
-> (ConstructorDef -> Either Text ToConstructor)
-> Either Text ToConstructor
tryConstructors [ConstructorDef]
constructors forall a b. (a -> b) -> a -> b
$ \c :: ConstructorDef
c@(ConstructorDef Text
_ Text
modifiedConstructorName [Text]
_ [Text]
_ [Text]
_) ->
case Value
value of
Object [(Key
tagValue, Value
contents)]
| Key -> Text
K.toText Key
tagValue forall a. Eq a => a -> a -> Bool
== Text
modifiedConstructorName ->
Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
contents
String Text
v
| Text
v forall a. Eq a => a -> a -> Bool
== Text
modifiedConstructorName ->
Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
value
Value
_ ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
P.show ConstructorDef
c
makeTwoElemArray :: Options -> [ConstructorDef] -> Value -> Either Text ToConstructor
makeTwoElemArray :: Options -> [ConstructorDef] -> Value -> Either Text ToConstructor
makeTwoElemArray Options
options [ConstructorDef]
constructors Value
value =
[ConstructorDef]
-> (ConstructorDef -> Either Text ToConstructor)
-> Either Text ToConstructor
tryConstructors [ConstructorDef]
constructors forall a b. (a -> b) -> a -> b
$ \c :: ConstructorDef
c@(ConstructorDef Text
_ Text
modifiedConstructorName [Text]
_ [Text]
_ [Text]
_) ->
case Value
value of
Array [Item Array
tagValue, Item Array
contents]
| Item Array
tagValue forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName ->
Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Item Array
contents
String Text
v
| Text
v forall a. Eq a => a -> a -> Bool
== Text
modifiedConstructorName ->
Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
value
Value
_ ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
P.show ConstructorDef
c
checkSumEncoding :: Options -> [ConstructorDef] -> Value -> Maybe Text
checkSumEncoding :: Options -> [ConstructorDef] -> Value -> Maybe Text
checkSumEncoding Options
options [ConstructorDef]
constructors Value
value = do
let constructorModifiedNames :: [Text]
constructorModifiedNames = ConstructorDef -> Text
constructorDefModifiedName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
constructors
case Options -> SumEncoding
sumEncoding Options
options of
TaggedObject (forall a b. ConvertText a b => a -> b
toS -> Text
tagFieldName) [Char]
_contentsFieldName ->
case Value
value of
Object Object
vs ->
case forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
tagFieldName) Object
vs of
Maybe Value
Nothing ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"tag field '" forall a. Semigroup a => a -> a -> a
<> Text
tagFieldName forall a. Semigroup a => a -> a -> a
<> Text
"' not found"
Just (String Text
tagValue)
| Text
tagValue forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames ->
forall a. Maybe a
Nothing
Just Value
v ->
[Text] -> Value -> Maybe Text
unexpectedConstructor [Text]
constructorModifiedNames Value
v
Value
_ -> forall a. a -> Maybe a
Just Text
"expected an Object for a TaggedObject sum encoding"
SumEncoding
UntaggedValue ->
forall a. Maybe a
Nothing
SumEncoding
ObjectWithSingleField ->
case Value
value of
Object [(Key
tagValue, Value
_)] ->
if Key -> Text
K.toText Key
tagValue forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames
then forall a. Maybe a
Nothing
else [Text] -> Value -> Maybe Text
unexpectedConstructor [Text]
constructorModifiedNames (Text -> Value
String forall a b. (a -> b) -> a -> b
$ Key -> Text
K.toText Key
tagValue)
String Text
v | Text
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames -> forall a. Maybe a
Nothing
Value
_ -> forall a. a -> Maybe a
Just Text
"expected an Object for an ObjectWithSingleField sum encoding"
SumEncoding
TwoElemArray ->
case Value
value of
Array [String Text
tagValue, Item Array
_] ->
if Text
tagValue forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames
then forall a. Maybe a
Nothing
else [Text] -> Value -> Maybe Text
unexpectedConstructor [Text]
constructorModifiedNames (Text -> Value
String Text
tagValue)
String Text
v | Text
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames -> forall a. Maybe a
Nothing
Value
_ -> forall a. a -> Maybe a
Just Text
"expected an Array with 2 elements for an TwoElemArray sum encoding"
where
unexpectedConstructor :: [Text] -> Value -> Maybe Text
unexpectedConstructor :: [Text] -> Value -> Maybe Text
unexpectedConstructor [Text]
expected (String Text
c) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"expected the tag field to be one of: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
expected forall a. Semigroup a => a -> a -> a
<> Text
", found: " forall a. Semigroup a => a -> a -> a
<> Text
c
unexpectedConstructor [Text]
expected Value
other = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"expected the tag field to be one of: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
expected forall a. Semigroup a => a -> a -> a
<> Text
", found: " forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (ByteString -> ByteString
BL.toStrict forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode Value
other)
applyOptions :: Options -> ConstructorDef -> ConstructorDef
applyOptions :: Options -> ConstructorDef -> ConstructorDef
applyOptions Options
options (ConstructorDef Text
constructorName Text
_ [Text]
fieldNames [Text]
_ [Text]
fieldTypes) =
Text -> Text -> [Text] -> [Text] -> [Text] -> ConstructorDef
ConstructorDef
Text
constructorName
(forall a b. ConvertText a b => a -> b
toS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ShowS
constructorTagModifier Options
options forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ Text
constructorName)
[Text]
fieldNames
(forall a b. ConvertText a b => a -> b
toS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ShowS
fieldLabelModifier Options
options forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
fieldNames)
[Text]
fieldTypes
makeToConstructorFromValue :: Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue :: Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
_options (ConstructorDef Text
constructorName Text
modifiedConstructorName [] [Text]
_ []) Value
value =
case Value
value of
String Text
v ->
if Text
v forall a. Eq a => a -> a -> Bool
== Text
modifiedConstructorName
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName []
else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"incorrect constructor name, expected: " forall a. Semigroup a => a -> a -> a
<> Text
modifiedConstructorName forall a. Semigroup a => a -> a -> a
<> Text
". Got: " forall a. Semigroup a => a -> a -> a
<> Text
v
Value
_ ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"incorrect constructor name, expected: " forall a. Semigroup a => a -> a -> a
<> Text
modifiedConstructorName forall a. Semigroup a => a -> a -> a
<> Text
". Got: " forall a. Semigroup a => a -> a -> a
<> forall a. ToJSON a => a -> Text
encodeAsText Value
value
makeToConstructorFromValue Options
_options (ConstructorDef Text
constructorName Text
_ [] [Text]
_ [Item [Text]
_]) Value
value =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(forall a. Maybe a
Nothing, Value
value)]
makeToConstructorFromValue Options
options (ConstructorDef Text
constructorName Text
_ [Item [Text]
f] [Item [Text]
mf] [Item [Text]
t]) Value
value =
if Options -> Bool
unwrapUnaryRecords Options
options
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(forall a. Maybe a
Nothing, Value
value)]
else case Value
value of
Object Object
fs ->
case forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Item [Text]
mf) Object
fs of
Just Value
v ->
if Options -> Bool
rejectUnknownFields Options
options Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length Object
fs forall a. Ord a => a -> a -> Bool
> Int
1
then do
let unknown :: [Text]
unknown = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Item [Text]
mf) forall a b. (a -> b) -> a -> b
$ Key -> Text
K.toText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. KeyMap v -> [Key]
KM.keys Object
fs
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"unknown field" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Foldable f => f a -> Text
plural [Text]
unknown forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
unknown
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(forall a. a -> Maybe a
Just (Item [Text]
f, Item [Text]
t), Value
v)]
Maybe Value
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"field '" forall a. Semigroup a => a -> a -> a
<> Item [Text]
mf forall a. Semigroup a => a -> a -> a
<> Text
"' not found" forall a. Semigroup a => a -> a -> a
<> (if Item [Text]
mf forall a. Eq a => a -> a -> Bool
== Item [Text]
f then Text
"" else Text
" (to create field '" forall a. Semigroup a => a -> a -> a
<> Item [Text]
f forall a. Semigroup a => a -> a -> a
<> Text
"')")
Value
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected an object with field '" forall a. Semigroup a => a -> a -> a
<> Item [Text]
mf forall a. Semigroup a => a -> a -> a
<> (if Item [Text]
mf forall a. Eq a => a -> a -> Bool
== Item [Text]
f then Text
"" else Text
" (to create field '" forall a. Semigroup a => a -> a -> a
<> Item [Text]
f forall a. Semigroup a => a -> a -> a
<> Text
"')")
makeToConstructorFromValue Options
options (ConstructorDef Text
constructorName Text
_ [Text]
_ [Text]
modifiedFieldNames [Text]
fieldTypes) Value
value =
case Value
value of
Object Object
vs -> do
let fieldsNotFound :: [Text]
fieldsNotFound = [Text]
modifiedFieldNames forall a. Eq a => [a] -> [a] -> [a]
\\ (Key -> Text
K.toText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. KeyMap v -> [Key]
KM.keys Object
vs)
if Bool -> Bool
not (Options -> Bool
omitNothingFields Options
options) Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fieldsNotFound)
then forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ case [Text]
fieldsNotFound of
[Item [Text]
f] -> Text
"field '" forall a. Semigroup a => a -> a -> a
<> Item [Text]
f forall a. Semigroup a => a -> a -> a
<> Text
"' not found"
[Text]
fs -> Text
"fields not found: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"," [Text]
fs
else do
let tagNames :: [[Char]]
tagNames = case Options -> SumEncoding
sumEncoding Options
options of
TaggedObject [Char]
t [Char]
c -> [[Char]
t, [Char]
c]
SumEncoding
_ -> []
let unknown :: [Text]
unknown = ((Key -> Text
K.toText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. KeyMap v -> [Key]
KM.keys Object
vs) forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
modifiedFieldNames) forall a. Eq a => [a] -> [a] -> [a]
\\ (forall a b. ConvertText a b => a -> b
toS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
tagNames)
if Options -> Bool
rejectUnknownFields Options
options Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
unknown)
then forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"unknown field" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Foldable f => f a -> Text
plural [Text]
unknown forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
unknown
else do
let fields :: [FieldDef]
fields = forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
modifiedFieldNames [Text]
fieldTypes
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Object -> FieldDef -> Maybe (Maybe FieldDef, Value)
getValue Object
vs) [FieldDef]
fields
where
getValue :: Object -> (Text, Text) -> Maybe (Maybe FieldDef, Value)
getValue :: Object -> FieldDef -> Maybe (Maybe FieldDef, Value)
getValue Object
actualFields (Text
fieldName, Text
fieldType) =
case forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
fieldName) Object
actualFields of
Just Value
v -> forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just (Text
fieldName, Text
fieldType), Value
v)
Maybe Value
Nothing ->
if Options -> Bool
omitNothingFields Options
options Bool -> Bool -> Bool
&& Text
"Maybe" Text -> Text -> Bool
`T.isPrefixOf` Text
fieldType
then forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just (Text
fieldName, Text
fieldType), Value
Null)
else forall a. Maybe a
Nothing
Array Array
vs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName ((forall a. Maybe a
Nothing,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
vs)
Value
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(forall a. Maybe a
Nothing, Value
value)]
type FieldDef = (Text, Text)
jsonTypeOf :: Value -> Text
jsonTypeOf :: Value -> Text
jsonTypeOf (Object Object
_) = Text
"an Object"
jsonTypeOf (Array Array
_) = Text
"an Array"
jsonTypeOf (String Text
_) = Text
"a String"
jsonTypeOf (Number Scientific
_) = Text
"a Number"
jsonTypeOf (Bool Bool
_) = Text
"a Bool"
jsonTypeOf Value
Null = Text
"Null"
tryConstructors :: [ConstructorDef] -> (ConstructorDef -> Either Text ToConstructor) -> Either Text ToConstructor
tryConstructors :: [ConstructorDef]
-> (ConstructorDef -> Either Text ToConstructor)
-> Either Text ToConstructor
tryConstructors [ConstructorDef]
constructors ConstructorDef -> Either Text ToConstructor
f = forall c. [Either Text c] -> Either Text c
foldEither forall a b. (a -> b) -> a -> b
$ ConstructorDef -> Either Text ToConstructor
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
constructors
foldEither :: [Either Text c] -> Either Text c
foldEither :: forall c. [Either Text c] -> Either Text c
foldEither [Either Text c]
es = do
let ([Text]
ls, [c]
rs) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text c]
es
case ([Text]
ls, [c]
rs) of
([], []) -> forall a b. a -> Either a b
Left Text
"no results"
([Text]
errors, []) -> forall a b. a -> Either a b
Left (Text -> [Text] -> Text
T.intercalate Text
" ->> " [Text]
errors)
([Text]
_, c
r : [c]
_) -> forall a b. b -> Either a b
Right c
r
encodeAsText :: (ToJSON a) => a -> Text
encodeAsText :: forall a. ToJSON a => a -> Text
encodeAsText = ByteString -> Text
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode
plural :: Foldable f => f a -> Text
plural :: forall (f :: * -> *) a. Foldable f => f a -> Text
plural f a
as = if forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
as) forall a. Ord a => a -> a -> Bool
> Int
1 then Text
"s" else Text
""