{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}

{-
  A Decoder is used to decode a Aeson Object into a specific data type
  This module provides several functions to create decoders and assemble them into a registry of encoders.
-}
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.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.ByteString.Lazy qualified as BL
import Data.List ((\\))
import Data.Map qualified as M
import Data.Registry
import Data.Registry.Aeson.TH.Decoder
import Data.Registry.Aeson.TH.ThOptions
import Data.Set qualified as S
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)

-- * DECODER DATA TYPE

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)

-- * DECODING

-- | Use a Decoder to decode a ByteString into the desired type
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

-- * CREATING KEY DECODERS

-- | Create a decoder for a key which can be read from text
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

-- * CREATING DECODERS

-- | Add a Decoder a to a registry of decoders when a Aeson a instance exists
--   usage: decoders = jsonDecoder @a <: otherDecoders
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)

-- * COMBINATORS

-- | Add a Maybe (Decoder a) to a registry of decoders
--   usage: decoders = decodeMaybeOf @a <: otherDecoders
--   the list of otherDecoders must contain a Decoder a
--   otherwise there will be a compilation error
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

-- | Add a Maybe (a, b) to a registry of decoders
--   usage: decoders = decodePairOf @a @b <: otherDecoders
--   the list of otherDecoders must contain a Decoder a and a Decoder b
--   otherwise there will be a compilation error
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

-- | Add a Maybe (a, b, c) to a registry of decoders
--   usage: decoders = decodeTripleOf @a @b @c <: otherDecoders
--   the list of otherDecoders must contain a Decoder a, a Decoder b and a Decoder c
--   otherwise there will be a compilation error
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

-- | Add a Decoder (Set a)
decodeSetOf :: forall a. (Typeable a, Ord a) => Typed (Decoder a -> Decoder (Set a))
decodeSetOf :: forall a.
(Typeable a, Ord a) =>
Typed (Decoder a -> Decoder (Set a))
decodeSetOf = forall a. Typeable a => a -> Typed a
fun (forall a. (Typeable a, Ord a) => Decoder a -> Decoder (Set a)
setOfDecoder @a)

setOfDecoder :: forall a. (Typeable a, Ord a) => Decoder a -> Decoder (Set a)
setOfDecoder :: forall a. (Typeable a, Ord a) => Decoder a -> Decoder (Set a)
setOfDecoder (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 a. Ord a => [a] -> Set a
S.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 (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 set of " forall a. Semigroup a => a -> a -> a
<> forall {k} (a :: k). Typeable a => [Char]
showType @a

-- | Add a Decoder [a] to a registry of decoders
--   usage: decoders = decodeListOf @a <: otherDecoders
--   the list of otherDecoders must contain a Decoder a
--   otherwise there will be a compilation error
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

-- | Add a Decoder (NonEmpty a) to a registry of decoders
--   usage: decoders = decodeNonEmptyOf @a <: otherDecoders
--   the list of otherDecoders must contain a Decoder a
--   otherwise there will be a compilation error
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))

-- * DEFAULT VALUES

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)

-- * TEMPLATE HASKELL

-- | Use a decoder to decode a field
--   The constructor name, the type where the field is inserted and the field definition
--   are used to provide better error messages
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

-- * CONSTRUCTOR DEFINITIONS

-- | Metadata for a given constructor in a data type
data ConstructorDef = ConstructorDef
  { -- | Name of the constructor
    ConstructorDef -> Text
constructorDefName :: Text,
    -- | Name of the constructor after modification with options
    ConstructorDef -> Text
constructorDefModifiedName :: Text,
    -- | Name of the constructor fields (if any are defined with names. An empty list otherwise)
    ConstructorDef -> [Text]
constructorDefFields :: [Text],
    -- | Names of the fields after modification with options
    ConstructorDef -> [Text]
constructorDefModifiedFieldNames :: [Text],
    -- | Types of the constructor fields
    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

-- * CONSTRUCTOR VALUES

-- | Data parsed from a given Value to be potentially used to create a constructor instance of a type
data ToConstructor = ToConstructor
  { -- | Name of the constructor to use (without modification)
    ToConstructor -> Text
toConstructorName :: Text,
    -- | Name of the values to decode for each field of the constructor instance
    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
")"

-- | Try to find the appropriate constructor definition encoded in the json value
--   then try to decode all its fields with decoding function
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

-- | This function extracts values for a set of constructor definitions
--   The TemplateHaskell function makeDecoder can then use the constructor name
--   and constructor field value to create an actual constructor instance for a given data type
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

-- | Try to extract possible constructor values based on:
--     - the encoding options
--     - the list of constructor definitions
--     - a JSON value
--   Several alternatives can be returned for an Untagged sum encoding when there are several
--   constructor definitions
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 the type is an enumeration
  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
      -- if there is only one constructor and tagging is not required (and nullary constructors must be tagged)
      [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

-- | Try to find which constructor was encoded in a tagged object where the tag field encode the constructor name
--   and the values are either inline in the object or in a contents field
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
              -- constructor with no fields
              ([], [], [])
                | 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 []
              -- constructor with one unnamed field
              ([], [], [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"
              -- constructor with one named field
              ([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"
              -- constructor with at least one named field and possibly Nothing fields
              ([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)
              -- constructor with several named fields
              ([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
              -- constructor with no named fields
              ([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"

-- | Try to find which constructor was encoded in an untagged value and extract its possible values
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

-- | Try to find which constructor was encoded in an object with a single field where the field name
--   encodes the constructor name and the object values encode the constructor fields
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

-- | Try to find which constructor was encoded in an array with 2 elements where the first element
--   encodes the constructor name and the other element the constructor values
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

-- | Check if the sum encoding structure looks correct
--   This requires the whole list of constructor definitions
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)

-- | Apply at runtime options to a constructor definition in order to be
--   able to match field definitions in the decoded json value
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

-- | For a given constructor definition extract all the required fields from a json value
makeToConstructorFromValue :: Options -> ConstructorDef -> Value -> Either Text ToConstructor
-- no field
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
-- one field, no field name
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)]
-- one field, one field name
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
"')")
-- several fields
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)]

-- | Field name + field type
type FieldDef = (Text, Text)

-- | Return a textual description of a json value
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"

-- | Try to extract a constructor and its values from a list of constructor definitions
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

-- | Return the first right element if available
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

-- | Encode a value as Text using its ToJSON instance
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

-- | Return a "s" if there are more than one element
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
""