{-# 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 where

import Control.Monad.Fail
import Data.Aeson
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Lazy as BL
import Data.List (nub, (\\))
import Data.Registry
import Data.Registry.Aeson.TH
import Data.Registry.Internal.Types hiding (Value)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as Vector
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude as P hiding (Type)
import Prelude (String, show)

-- * DECODER DATA TYPE

newtype Decoder a = Decoder {Decoder a -> Value -> Either Text a
decodeValue :: Value -> Either Text a}

instance Functor Decoder where
  fmap :: (a -> b) -> Decoder a -> Decoder b
fmap a -> b
f (Decoder Value -> Either Text a
d) = (Value -> Either Text b) -> Decoder b
forall a. (Value -> Either Text a) -> Decoder a
Decoder ((a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Either Text a -> Either Text b)
-> (Value -> Either Text a) -> Value -> Either Text b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either Text a
d)

instance Applicative Decoder where
  pure :: a -> Decoder a
pure a
a = (Value -> Either Text a) -> Decoder a
forall a. (Value -> Either Text a) -> Decoder a
Decoder (Either Text a -> Value -> Either Text a
forall a b. a -> b -> a
const (a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a))
  Decoder (a -> b)
f <*> :: Decoder (a -> b) -> Decoder a -> Decoder b
<*> Decoder a
a = ((a -> b) -> a -> b) -> (a -> b, a) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($) ((a -> b, a) -> b) -> Decoder (a -> b, a) -> Decoder b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder (a -> b) -> Decoder a -> Decoder (a -> b, a)
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 :: Decoder a -> Decoder b -> Decoder (a, b)
decoderAp (Decoder Value -> Either Text a
da) (Decoder Value -> Either Text b
db) = (Value -> Either Text (a, b)) -> Decoder (a, b)
forall a. (Value -> Either Text a) -> Decoder a
Decoder ((Value -> Either Text (a, b)) -> Decoder (a, b))
-> (Value -> Either Text (a, b)) -> Decoder (a, b)
forall a b. (a -> b) -> a -> b
$ \case
  o :: Value
o@(Array Array
ls) ->
    case [Value] -> [Value]
forall a. [a] -> [a]
reverse (Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
ls) of
      Value
b : [Value]
as -> (,) (a -> b -> (a, b)) -> Either Text a -> Either Text (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
da (Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ([Value] -> Array) -> [Value] -> Array
forall a b. (a -> b) -> a -> b
$ [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
as) Either Text (b -> (a, b)) -> Either Text b -> Either Text (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
db Value
b
      [] -> (,) (a -> b -> (a, b)) -> Either Text a -> Either Text (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
da Value
o Either Text (b -> (a, b)) -> Either Text b -> Either Text (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
db Value
o
  Value
o -> (,) (a -> b -> (a, b)) -> Either Text a -> Either Text (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
da Value
o Either Text (b -> (a, b)) -> Either Text b -> Either Text (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
db Value
o

-- * 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 :: Decoder a -> ByteString -> Either Text a
decodeByteString Decoder a
d ByteString
bs =
  case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs of
    Left String
e -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"Cannot parse the string as a Value: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. (Show a, StringConv String b) => a -> b
P.show String
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". The string is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. (Show a, StringConv String b) => a -> b
P.show ByteString
bs
    Right Value
v ->
      case Decoder a -> Value -> Either Text a
forall a. Decoder a -> Value -> Either Text a
decodeValue Decoder a
d Value
v of
        Right a
a -> a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        Left Text
e -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"Cannot decode the type '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS (Typeable a => String
forall a. Typeable a => String
showType @a) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' >> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

-- * 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 :: Typed (Decoder a)
jsonDecoder = Decoder a -> Typed (Decoder a)
forall a. Typeable a => a -> Typed a
fun (FromJSON a => Decoder a
forall a. FromJSON a => Decoder a
jsonDecoderOf @a)

jsonDecoderOf :: FromJSON a => Decoder a
jsonDecoderOf :: Decoder a
jsonDecoderOf = (Value -> Either Text a) -> Decoder a
forall a. (Value -> Either Text a) -> Decoder a
Decoder ((Value -> Either Text a) -> Decoder a)
-> (Value -> Either Text a) -> Decoder a
forall a b. (a -> b) -> a -> b
$ \Value
v ->
  case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
    Success a
a -> a -> Either Text a
forall a b. b -> Either a b
Right a
a
    Error String
e -> Text -> Either Text a
forall a b. a -> Either a b
Left (String -> Text
forall a b. ConvertText a b => a -> b
toS String
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 :: Typed (Decoder a -> Decoder (Maybe a))
decodeMaybeOf = (Decoder a -> Decoder (Maybe a))
-> Typed (Decoder a -> Decoder (Maybe a))
forall a. Typeable a => a -> Typed a
fun (Decoder a -> Decoder (Maybe a)
forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder @a)

maybeOfDecoder :: forall a. Decoder a -> Decoder (Maybe a)
maybeOfDecoder :: Decoder a -> Decoder (Maybe a)
maybeOfDecoder (Decoder Value -> Either Text a
d) = (Value -> Either Text (Maybe a)) -> Decoder (Maybe a)
forall a. (Value -> Either Text a) -> Decoder a
Decoder ((Value -> Either Text (Maybe a)) -> Decoder (Maybe a))
-> (Value -> Either Text (Maybe a)) -> Decoder (Maybe a)
forall a b. (a -> b) -> a -> b
$ \case
  Value
Null -> Maybe a -> Either Text (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  Value
just -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either Text a -> Either Text (Maybe a)
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 :: Typed (Decoder a -> Decoder b -> Decoder (a, b))
decodePairOf = (Decoder a -> Decoder b -> Decoder (a, b))
-> Typed (Decoder a -> Decoder b -> Decoder (a, b))
forall a. Typeable a => a -> Typed a
fun ((Typeable a, Typeable b) =>
Decoder a -> Decoder b -> Decoder (a, b)
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 :: Decoder a -> Decoder b -> Decoder (a, b)
pairOfDecoder (Decoder Value -> Either Text a
a) (Decoder Value -> Either Text b
b) = (Value -> Either Text (a, b)) -> Decoder (a, b)
forall a. (Value -> Either Text a) -> Decoder a
Decoder ((Value -> Either Text (a, b)) -> Decoder (a, b))
-> (Value -> Either Text (a, b)) -> Decoder (a, b)
forall a b. (a -> b) -> a -> b
$ \case
  Array [Item Array
oa, Item Array
ob] -> (,) (a -> b -> (a, b)) -> Either Text a -> Either Text (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
a Value
Item Array
oa Either Text (b -> (a, b)) -> Either Text b -> Either Text (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
b Value
Item Array
ob
  Value
_ -> Text -> Either Text (a, b)
forall a b. a -> Either a b
Left (Text -> Either Text (a, b))
-> (String -> Text) -> String -> Either Text (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Either Text (a, b)) -> String -> Either Text (a, b)
forall a b. (a -> b) -> a -> b
$ String
"not a pair of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable b => String
forall a. Typeable a => String
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 :: Typed (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
decodeTripleOf = (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
-> Typed (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))
forall a. Typeable a => a -> Typed a
fun ((Typeable a, Typeable b, Typeable c) =>
Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)
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 :: 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) = (Value -> Either Text (a, b, c)) -> Decoder (a, b, c)
forall a. (Value -> Either Text a) -> Decoder a
Decoder ((Value -> Either Text (a, b, c)) -> Decoder (a, b, c))
-> (Value -> Either Text (a, b, c)) -> Decoder (a, b, c)
forall a b. (a -> b) -> a -> b
$ \case
  Array [Item Array
oa, Item Array
ob, Item Array
oc] -> (,,) (a -> b -> c -> (a, b, c))
-> Either Text a -> Either Text (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
a Value
Item Array
oa Either Text (b -> c -> (a, b, c))
-> Either Text b -> Either Text (c -> (a, b, c))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text b
b Value
Item Array
ob Either Text (c -> (a, b, c))
-> Either Text c -> Either Text (a, b, c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text c
c Value
Item Array
oc
  Value
_ -> Text -> Either Text (a, b, c)
forall a b. a -> Either a b
Left (Text -> Either Text (a, b, c))
-> (String -> Text) -> String -> Either Text (a, b, c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Either Text (a, b, c))
-> String -> Either Text (a, b, c)
forall a b. (a -> b) -> a -> b
$ String
"not a triple of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable b => String
forall a. Typeable a => String
showType @b String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable c => String
forall a. Typeable a => String
showType @c

-- | 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 :: Typed (Decoder a -> Decoder [a])
decodeListOf = (Decoder a -> Decoder [a]) -> Typed (Decoder a -> Decoder [a])
forall a. Typeable a => a -> Typed a
fun (Typeable a => Decoder a -> Decoder [a]
forall a. Typeable a => Decoder a -> Decoder [a]
listOfDecoder @a)

listOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder [a]
listOfDecoder :: Decoder a -> Decoder [a]
listOfDecoder (Decoder Value -> Either Text a
a) = (Value -> Either Text [a]) -> Decoder [a]
forall a. (Value -> Either Text a) -> Decoder a
Decoder ((Value -> Either Text [a]) -> Decoder [a])
-> (Value -> Either Text [a]) -> Decoder [a]
forall a b. (a -> b) -> a -> b
$ \case
  Array Array
vs -> [Value] -> (Value -> Either Text a) -> Either Text [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
vs) Value -> Either Text a
a
  Value
_ -> Text -> Either Text [a]
forall a b. a -> Either a b
Left (Text -> Either Text [a])
-> (String -> Text) -> String -> Either Text [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Either Text [a]) -> String -> Either Text [a]
forall a b. (a -> b) -> a -> b
$ String
"not a list of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a

-- | 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 :: Typed (Decoder a -> Decoder (NonEmpty a))
decodeNonEmptyOf = (Decoder a -> Decoder (NonEmpty a))
-> Typed (Decoder a -> Decoder (NonEmpty a))
forall a. Typeable a => a -> Typed a
fun (Typeable a => Decoder a -> Decoder (NonEmpty a)
forall a. Typeable a => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder @a)

nonEmptyOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder :: Decoder a -> Decoder (NonEmpty a)
nonEmptyOfDecoder (Decoder Value -> Either Text a
a) = (Value -> Either Text (NonEmpty a)) -> Decoder (NonEmpty a)
forall a. (Value -> Either Text a) -> Decoder a
Decoder ((Value -> Either Text (NonEmpty a)) -> Decoder (NonEmpty a))
-> (Value -> Either Text (NonEmpty a)) -> Decoder (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ \case
  Array Array
values ->
    case Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
values of
      [] -> Text -> Either Text (NonEmpty a)
forall a b. a -> Either a b
Left (Text -> Either Text (NonEmpty a))
-> (String -> Text) -> String -> Either Text (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Either Text (NonEmpty a))
-> String -> Either Text (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ String
"expected a NonEmpty of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a
      Value
o : [Value]
os -> a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> NonEmpty a)
-> Either Text a -> Either Text ([a] -> NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text a
a Value
o Either Text ([a] -> NonEmpty a)
-> Either Text [a] -> Either Text (NonEmpty a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Value] -> (Value -> Either Text a) -> Either Text [a]
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
_ -> Text -> Either Text (NonEmpty a)
forall a b. a -> Either a b
Left (Text -> Either Text (NonEmpty a))
-> (String -> Text) -> String -> Either Text (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Either Text (NonEmpty a))
-> String -> Either Text (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ String
"not a list of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Typeable a => String
forall a. Typeable a => String
showType @a

showType :: forall a. (Typeable a) => String
showType :: String
showType = TypeRep -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))

-- * TEMPLATE HASKELL

-- | Make a Decoder for a given data type
--   Usage: $(makeDecoder ''MyDataType <: otherDecoders)
makeDecoder :: Name -> ExpQ
makeDecoder :: Name -> ExpQ
makeDecoder Name
typeName = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fun") (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ do
  Info
info <- Name -> Q Info
reify Name
typeName
  case Info
info of
    TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind Con
constructor [DerivClause]
_deriving) ->
      Name -> [Con] -> ExpQ
makeConstructorsDecoder Name
typeName [Item [Con]
Con
constructor]
    TyConI (DataD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind [Con]
constructors [DerivClause]
_deriving) -> do
      case [Con]
constructors of
        [] -> do
          Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True String
"can not make an Decoder for an empty data type"
          String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decoders creation failed"
        [Con]
_ -> Name -> [Con] -> ExpQ
makeConstructorsDecoder Name
typeName [Con]
constructors
    Info
other -> do
      Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only create decoders for an ADT, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Info
other)
      String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decoders creation failed"

-- | Make a decoder for a given data type by extracting just enough metadata about the data type in order to be able
--   to parse a Value
--
--   For example for the data type:
--
--   data T = T1 {f1::Int, f2::Int} | T2 Int Int
--
--   we add this function to the registry:
--
--   \opts d1 d2 d3 -> Decoder $ \v ->
--     decodeFromDefinitions opts v $ \case
--       ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ...
--       ToConstructor "T2" [v1, v2]-> T2 <$> d1 v1 <*> d3 v2 ...
--       other -> Left ("cannot decode " <> valueToText v)
--
--   The \case function is the only one which needs to be generated in order to match the exact shape of the
--   constructors to instantiate
makeConstructorsDecoder :: Name -> [Con] -> ExpQ
makeConstructorsDecoder :: Name -> [Con] -> ExpQ
makeConstructorsDecoder Name
typeName [Con]
cs = do
  Cxt
ts <- Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt -> Cxt) -> ([Cxt] -> Cxt) -> [Cxt] -> Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cxt] -> Cxt
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([Cxt] -> Cxt) -> Q [Cxt] -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con] -> (Con -> Q Cxt) -> Q [Cxt]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs Con -> Q Cxt
typesOf
  let decoderParameters :: [PatQ]
decoderParameters = PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName String
"os")) (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Options") PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: ((\(Kind
t, Integer
n) -> PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"d" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Integer
n)) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Decoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t))) ((Kind, Integer) -> PatQ) -> [(Kind, Integer)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> [Integer] -> [(Kind, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
ts [Item [Integer]
0 ..])
  -- makeToConstructors os [Constructor "T1" ["f1", "f2"], Constructor "T2" []] v
  let paramP :: PatQ
paramP = Name -> PatQ
varP (String -> Name
mkName String
"v")
  [Exp]
constructorDefs <- [Con] -> (Con -> ExpQ) -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs ((Con -> ExpQ) -> Q [Exp]) -> (Con -> ExpQ) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \Con
c -> do
    Name
cName <- Name -> Name
dropQualified (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
    [ExpQ]
fields <- (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Lit -> ExpQ
litE (Lit -> ExpQ) -> (Name -> Lit) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
dropQualified) ([Name] -> [ExpQ]) -> Q [Name] -> Q [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q [Name]
fieldsOf Con
c
    [ExpQ]
fieldTypes <- (Kind -> ExpQ) -> Cxt -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Lit -> ExpQ
litE (Lit -> ExpQ) -> (Kind -> Lit) -> Kind -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Kind -> String) -> Kind -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show (Name -> String) -> (Kind -> Name) -> Kind -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Name
getSimpleTypeName) (Cxt -> [ExpQ]) -> Q Cxt -> Q [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Cxt
typesOf Con
c
    Name -> ExpQ
varE (String -> Name
mkName String
"makeConstructorDef") ExpQ -> ExpQ -> ExpQ
`appE` (Lit -> ExpQ
litE (Lit -> ExpQ) -> (String -> Lit) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Name
cName) ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE [ExpQ]
fields ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE [ExpQ]
fieldTypes
  let matchClauses :: [MatchQ]
matchClauses = Name -> Cxt -> Con -> MatchQ
makeMatchClause Name
typeName Cxt
ts (Con -> MatchQ) -> [Con] -> [MatchQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cs
  let matchFunction :: ExpQ
matchFunction = [MatchQ] -> ExpQ
lamCaseE ([MatchQ]
matchClauses [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. Semigroup a => a -> a -> a
<> [Name -> MatchQ
makeErrorClause Name
typeName])
  let resolveFunction :: ExpQ
resolveFunction = Name -> ExpQ
varE (String -> Name
mkName String
"decodeFromDefinitions") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"os") ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> [Exp] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp]
constructorDefs) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"v") ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
matchFunction
  [PatQ] -> ExpQ -> ExpQ
lamE [PatQ]
decoderParameters (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"Decoder")) ([PatQ] -> ExpQ -> ExpQ
lamE [PatQ
Item [PatQ]
paramP] ExpQ
resolveFunction))

-- | Decode the nth constructor of a data type
--    ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ...
makeMatchClause :: Name -> [Type] -> Con -> MatchQ
makeMatchClause :: Name -> Cxt -> Con -> MatchQ
makeMatchClause Name
typeName Cxt
allTypes Con
c = do
  Cxt
ts <- Con -> Q Cxt
typesOf Con
c
  [Int]
constructorTypes <- ((Kind, Int) -> Int) -> [(Kind, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind, Int) -> Int
forall a b. (a, b) -> b
snd ([(Kind, Int)] -> [Int]) -> Q [(Kind, Int)] -> Q [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> Cxt -> Q [(Kind, Int)]
indexConstructorTypes Cxt
allTypes Cxt
ts
  Name
cName <- Name -> Name
dropQualified (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let fieldsP :: PatQ
fieldsP = [PatQ] -> PatQ
listP ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (\Int
i -> Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Int
i)) (Int -> PatQ) -> [Int] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
constructorTypes
  PatQ -> BodyQ -> [DecQ] -> MatchQ
match
    (Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
"ToConstructor") [Lit -> PatQ
litP (String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show (Name -> Lit) -> Name -> Lit
forall a b. (a -> b) -> a -> b
$ Name
cName), PatQ
Item [PatQ]
fieldsP])
    (ExpQ -> BodyQ
normalB (Name -> Name -> [Int] -> ExpQ
applyDecoder Name
typeName Name
cName [Int]
constructorTypes))
    []

-- | Return an error the json value cannot be decoded with a constructor name and some values
makeErrorClause :: Name -> MatchQ
makeErrorClause :: Name -> MatchQ
makeErrorClause Name
typeName = do
  let errorMessage :: ExpQ
errorMessage =
        (Name -> ExpQ
varE (String -> Name
mkName String
"<>") ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
litE (String -> Lit
StringL (String
"cannot use this constructor to create an instance of type '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Name
typeName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"': ")))
          ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE (String -> Name
mkName String
"show") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"_1"))
  PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"_1") (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Left") ExpQ
errorMessage)) []

-- ConstructorName <$> decodeFieldValue d1 o1 <*> decodeFieldValue d2 o2 ...
applyDecoder :: Name -> Name -> [Int] -> ExpQ
applyDecoder :: Name -> Name -> [Int] -> ExpQ
applyDecoder Name
_typeName Name
cName [] = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pure") (Name -> ExpQ
conE Name
cName)
applyDecoder Name
typeName Name
cName (Int
n : [Int]
ns) = do
  let cons :: ExpQ
cons = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pure") (Name -> ExpQ
conE Name
cName)
  (Int -> ExpQ -> ExpQ) -> ExpQ -> [Int] -> ExpQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
i ExpQ
r -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"ap")) ExpQ
r) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Int -> ExpQ
decodeAt Int
i) (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"ap")) ExpQ
cons) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Int -> ExpQ
decodeAt Int
n) ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
ns)
  where
    decodeAt :: Int -> ExpQ
decodeAt Int
i =
      Name -> ExpQ
varE (String -> Name
mkName String
"decodeFieldValue") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName (String
"d" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Int
i))
        ExpQ -> ExpQ -> ExpQ
`appE` (Lit -> ExpQ
litE (Lit -> ExpQ) -> (Name -> Lit) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
dropQualified (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name
typeName)
        ExpQ -> ExpQ -> ExpQ
`appE` (Lit -> ExpQ
litE (Lit -> ExpQ) -> (Name -> Lit) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
dropQualified (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name
cName)
        ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName (String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Int
i))

-- | 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 :: Decoder a
-> Text -> Text -> (Maybe FieldDef, Value) -> Either Text a
decodeFieldValue Decoder a
d Text
typeName Text
constructorName (Maybe FieldDef
field, Value
v) =
  case Decoder a -> Value -> Either Text a
forall a. Decoder a -> Value -> Either Text a
decodeValue Decoder a
d Value
v of
    Right a
a -> a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left Text
e -> do
      let constructor :: Text
constructor = if Text
typeName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
constructorName then Text
"" else Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
constructorName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") "
      Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> (FieldDef -> Text) -> Maybe FieldDef -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
constructor (\(Text
fn, Text
ft) -> Text
constructor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ft Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' >> ") Maybe FieldDef
field Text -> Text -> Text
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
(ConstructorDef -> ConstructorDef -> Bool)
-> (ConstructorDef -> ConstructorDef -> Bool) -> Eq ConstructorDef
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 -> String
show (ConstructorDef Text
n Text
_ [] [Text]
_ [Text]
fts) =
    Text -> String
forall a b. ConvertText a b => a -> b
toS (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
fts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]"
  show (ConstructorDef Text
n Text
_ [Text]
fns [Text]
_ [Text]
fts) =
    Text -> String
forall a b. ConvertText a b => a -> b
toS (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" {" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((\(Text
fn, Text
ft) -> Text
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ft) (FieldDef -> Text) -> [FieldDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> [Text] -> [FieldDef]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fns [Text]
fts)) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}"

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
(ToConstructor -> ToConstructor -> Bool)
-> (ToConstructor -> ToConstructor -> Bool) -> Eq ToConstructor
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 -> String
show (ToConstructor Text
constructorName [(Maybe FieldDef, Value)]
values) =
    Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
constructorName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((Maybe FieldDef, Value) -> Text
forall a. ToJSON a => a -> Text
encodeAsText ((Maybe FieldDef, Value) -> Text)
-> [(Maybe FieldDef, Value)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe FieldDef, Value)]
values) Text -> Text -> Text
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 -> [ConstructorDef] -> Value -> (ToConstructor -> Either Text a) -> Either Text a
decodeFromDefinitions :: Options
-> [ConstructorDef]
-> Value
-> (ToConstructor -> Either Text a)
-> Either Text a
decodeFromDefinitions Options
options [ConstructorDef]
constructorDefs Value
value ToConstructor -> Either Text a
build = do
  let toConstructors :: Either Text [Either Text a]
toConstructors = (ToConstructor -> Either Text a)
-> [ToConstructor] -> [Either Text a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ToConstructor -> Either Text a
build ([ToConstructor] -> [Either Text a])
-> Either Text [ToConstructor] -> Either Text [Either Text a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]
makeToConstructors Options
options [ConstructorDef]
constructorDefs Value
value
  case Either Text [Either Text a]
toConstructors of
    Left Text
e -> Text -> Either Text a
forall a b. a -> Either a b
Left Text
e
    Right [Either Text a]
es -> [Either Text a] -> Either Text a
forall c. [Either Text c] -> Either Text c
foldEither [Either Text a]
es

-- | 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 (ConstructorDef -> ConstructorDef)
-> [ConstructorDef] -> [ConstructorDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
cs
  let isEnumeration :: Bool
isEnumeration = (ConstructorDef -> Bool) -> [ConstructorDef] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool)
-> (ConstructorDef -> [Text]) -> ConstructorDef -> Bool
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 (ConstructorDef -> Bool)
-> [ConstructorDef] -> Maybe ConstructorDef
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) (Text -> Bool)
-> (ConstructorDef -> Text) -> ConstructorDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorDef -> Text
constructorDefModifiedName) [ConstructorDef]
constructors of
          Just ConstructorDef
c -> ToConstructor -> Either Text [ToConstructor]
forall (f :: * -> *) (g :: * -> *) a.
(Applicative f, Applicative g) =>
a -> f (g a)
purer (ToConstructor -> Either Text [ToConstructor])
-> ToConstructor -> Either Text [ToConstructor]
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor (ConstructorDef -> Text
constructorDefName ConstructorDef
c) []
          Maybe ConstructorDef
Nothing -> Text -> Either Text [ToConstructor]
forall a b. a -> Either a b
Left (Text -> Either Text [ToConstructor])
-> Text -> Either Text [ToConstructor]
forall a b. (a -> b) -> a -> b
$ Text
"expected one of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (ConstructorDef -> Text
constructorDefModifiedName (ConstructorDef -> Text) -> [ConstructorDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
constructors) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, StringConv String b) => a -> b
P.show Text
name
      Value
other -> Text -> Either Text [ToConstructor]
forall a b. a -> Either a b
Left (Text -> Either Text [ToConstructor])
-> Text -> Either Text [ToConstructor]
forall a b. (a -> b) -> a -> b
$ Text
"expected one of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (ConstructorDef -> Text
constructorDefName (ConstructorDef -> Text) -> [ConstructorDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
constructors) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
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)) ->
          ToConstructor -> [ToConstructor]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> [ToConstructor])
-> Either Text ToConstructor -> Either Text [ToConstructor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options Item [ConstructorDef]
ConstructorDef
c Value
value
      [ConstructorDef]
_ -> do
        Either Text ()
-> (Text -> Either Text ()) -> Maybe Text -> Either Text ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either Text ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Text -> Either Text ()
forall a b. a -> Either a b
Left (Maybe Text -> Either Text ()) -> Maybe Text -> Either Text ()
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 (String -> Text
forall a b. ConvertText a b => a -> b
toS -> Text
tagFieldName) (String -> Text
forall a b. ConvertText a b => a -> b
toS -> Text
contentsFieldName) ->
            ToConstructor -> [ToConstructor]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> [ToConstructor])
-> Either Text ToConstructor -> Either Text [ToConstructor]
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 ->
            ToConstructor -> [ToConstructor]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> [ToConstructor])
-> Either Text ToConstructor -> Either Text [ToConstructor]
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 ->
            ToConstructor -> [ToConstructor]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> [ToConstructor])
-> Either Text ToConstructor -> Either Text [ToConstructor]
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 ((ConstructorDef -> Either Text ToConstructor)
 -> Either Text ToConstructor)
-> (ConstructorDef -> Either Text ToConstructor)
-> Either Text ToConstructor
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 Key -> Object -> Maybe Value
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 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName ->
                  ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName []
              -- constructor with one unnamed field
              ([], [], [Item [Text]
_])
                | Value
tagValue Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName ->
                  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
contentsFieldName) Object
vs of
                    Just Value
fieldValue -> ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(Maybe FieldDef
forall a. Maybe a
Nothing, Value
fieldValue)]
                    Maybe Value
Nothing -> Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contentsFieldName Text -> Text -> Text
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 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName ->
                  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
Item [Text]
modifiedFieldName) Object
vs of
                    Just Value
fieldValue -> ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(FieldDef -> Maybe FieldDef
forall a. a -> Maybe a
Just (Text
Item [Text]
fieldName, Text
Item [Text]
fieldType), Value
fieldValue)]
                    Maybe Value
Nothing -> Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Item [Text]
modifiedFieldName Text -> Text -> Text
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 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName Bool -> Bool -> Bool
&& Options -> Bool
omitNothingFields Options
options Bool -> Bool -> Bool
&& (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
modifiedFieldNames) (Key -> Text
K.toText (Key -> Text) -> [Key] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
vs) -> do
                  let rest :: Object
rest = [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList ([(Key, Value)] -> Object) -> [(Key, Value)] -> Object
forall a b. (a -> b) -> a -> b
$ ((Key, Value) -> Bool) -> [(Key, Value)] -> [(Key, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
tagFieldName) (Text -> Bool) -> ((Key, Value) -> Text) -> (Key, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText (Key -> Text) -> ((Key, Value) -> Key) -> (Key, Value) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Value) -> Key
forall a b. (a, b) -> a
fst) ([(Key, Value)] -> [(Key, Value)])
-> [(Key, Value)] -> [(Key, Value)]
forall a b. (a -> b) -> a -> b
$ Object -> [(Key, Value)]
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 Value -> Value -> Bool
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 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName Bool -> Bool -> Bool
&& (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
contentsFieldName) (Key -> Text
K.toText (Key -> Text) -> [Key] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
vs) ->
                  case Key -> Object -> Maybe Value
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
_ -> Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"contents field not found '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contentsFieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
              ([Text]
_, [Text]
_, [Text]
_) ->
                Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConstructorDef -> Text
forall a b. (Show a, StringConv String b) => a -> b
P.show ConstructorDef
c
          Maybe Value
Nothing ->
            Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConstructorDef -> Text
forall a b. (Show a, StringConv String b) => a -> b
P.show ConstructorDef
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". tag field not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagFieldName
      Value
_ ->
        Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConstructorDef -> Text
forall a b. (Show a, StringConv String b) => a -> b
P.show ConstructorDef
c Text -> Text -> Text
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 [Either Text ToConstructor] -> ([Text], [ToConstructor])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Text ToConstructor] -> ([Text], [ToConstructor]))
-> [Either Text ToConstructor] -> ([Text], [ToConstructor])
forall a b. (a -> b) -> a -> b
$ (\ConstructorDef
c -> Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
value) (ConstructorDef -> Either Text ToConstructor)
-> [ConstructorDef] -> [Either Text ToConstructor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
constructors of
    (Text
e : [Text]
_, []) -> Text -> Either Text [ToConstructor]
forall a b. a -> Either a b
Left Text
e
    ([], []) -> Text -> Either Text [ToConstructor]
forall a b. a -> Either a b
Left Text
"no constructors"
    ([Text]
_, [ToConstructor]
rs) -> [ToConstructor] -> Either Text [ToConstructor]
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 ((ConstructorDef -> Either Text ToConstructor)
 -> Either Text ToConstructor)
-> (ConstructorDef -> Either Text ToConstructor)
-> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ \c :: ConstructorDef
c@(ConstructorDef Text
_ Text
modifiedConstructorName [Text]
_ [Text]
_ [Text]
_) ->
    case Value
value of
      Object [(tagValue, contents)]
        | Key -> Text
K.toText Key
tagValue Text -> Text -> Bool
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
modifiedConstructorName ->
          Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
value
      Value
_ ->
        Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConstructorDef -> Text
forall a b. (Show a, StringConv String 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 ((ConstructorDef -> Either Text ToConstructor)
 -> Either Text ToConstructor)
-> (ConstructorDef -> Either Text ToConstructor)
-> Either Text ToConstructor
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]
        | Value
Item Array
tagValue Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Value
String Text
modifiedConstructorName ->
          Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
Item Array
contents
      String Text
v
        | Text
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
modifiedConstructorName ->
          Options -> ConstructorDef -> Value -> Either Text ToConstructor
makeToConstructorFromValue Options
options ConstructorDef
c Value
value
      Value
_ ->
        Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"failed to instantiate constructor: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConstructorDef -> Text
forall a b. (Show a, StringConv String 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 (ConstructorDef -> Text) -> [ConstructorDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorDef]
constructors
  case Options -> SumEncoding
sumEncoding Options
options of
    TaggedObject (String -> Text
forall a b. ConvertText a b => a -> b
toS -> Text
tagFieldName) String
_contentsFieldName ->
      case Value
value of
        Object Object
vs ->
          case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
tagFieldName) Object
vs of
            Maybe Value
Nothing ->
              Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"tag field '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagFieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' not found"
            Just (String Text
tagValue)
              | Text
tagValue Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames ->
                Maybe Text
forall a. Maybe a
Nothing
            Just Value
v ->
              [Text] -> Value -> Maybe Text
unexpectedConstructor [Text]
constructorModifiedNames Value
v
        Value
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"expected an Object for a TaggedObject sum encoding"
    SumEncoding
UntaggedValue ->
      Maybe Text
forall a. Maybe a
Nothing
    SumEncoding
ObjectWithSingleField ->
      case Value
value of
        Object [(tagValue, _)] ->
          if Key -> Text
K.toText Key
tagValue Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames
            then Maybe Text
forall a. Maybe a
Nothing
            else [Text] -> Value -> Maybe Text
unexpectedConstructor [Text]
constructorModifiedNames (Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Text
K.toText Key
tagValue)
        String Text
v | Text
v Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames -> Maybe Text
forall a. Maybe a
Nothing
        Value
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"expected an Object for an ObjectWithSingleField sum encoding"
    SumEncoding
TwoElemArray ->
      case Value
value of
        Array [String tagValue, Item Array
_] ->
          if Text
tagValue Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames
            then Maybe Text
forall a. Maybe a
Nothing
            else [Text] -> Value -> Maybe Text
unexpectedConstructor [Text]
constructorModifiedNames (Text -> Value
String Text
tagValue)
        String Text
v | Text
v Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
constructorModifiedNames -> Maybe Text
forall a. Maybe a
Nothing
        Value
_ -> Text -> Maybe Text
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) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"expected the tag field to be one of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
expected Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c
    unexpectedConstructor [Text]
expected Value
other = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"expected the tag field to be one of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
expected Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
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
    (String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> String -> String
constructorTagModifier Options
options (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
constructorName)
    [Text]
fieldNames
    (String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> String -> String
fieldLabelModifier Options
options (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> Text) -> [Text] -> [Text]
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
modifiedConstructorName
        then ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName []
        else Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"incorrect constructor name, expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modifiedConstructorName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v
    Value
_ ->
      Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"incorrect constructor name, expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
modifiedConstructorName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
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 =
  ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(Maybe FieldDef
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 ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(Maybe FieldDef
forall a. Maybe a
Nothing, Value
value)]
    else case Value
value of
      Object Object
fs ->
        case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
Item [Text]
mf) Object
fs of
          Just Value
v ->
            if Options -> Bool
rejectUnknownFields Options
options Bool -> Bool -> Bool
&& Object -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Object
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
              then do
                let unknown :: [Text]
unknown = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
Item [Text]
mf) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Key -> Text
K.toText (Key -> Text) -> [Key] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
fs
                Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"unknown field" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall (f :: * -> *) a. Foldable f => f a -> Text
plural [Text]
unknown Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
unknown
              else ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(FieldDef -> Maybe FieldDef
forall a. a -> Maybe a
Just (Text
Item [Text]
f, Text
Item [Text]
t), Value
v)]
          Maybe Value
Nothing -> Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"field '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Item [Text]
mf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' not found" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Text
Item [Text]
mf Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
Item [Text]
f then Text
"" else Text
" (to create field '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Item [Text]
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"')")
      Value
_ -> Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"expected an object with field '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Item [Text]
mf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Text
Item [Text]
mf Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
Item [Text]
f then Text
"" else Text
" (to create field '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Item [Text]
f Text -> Text -> Text
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 [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ (Key -> Text
K.toText (Key -> Text) -> [Key] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
vs)
      if Bool -> Bool
not (Options -> Bool
omitNothingFields Options
options) Bool -> Bool -> Bool
&& Bool -> Bool
not ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fieldsNotFound)
        then Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ case [Text]
fieldsNotFound of
          [Item [Text]
f] -> Text
"field '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Item [Text]
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' not found"
          [Text]
fs -> Text
"fields  not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"," [Text]
fs
        else do
          let tagNames :: [String]
tagNames = case Options -> SumEncoding
sumEncoding Options
options of
                TaggedObject String
t String
c -> [String
Item [String]
t, String
Item [String]
c]
                SumEncoding
_ -> []
          let unknown :: [Text]
unknown = ((Key -> Text
K.toText (Key -> Text) -> [Key] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
vs) [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
modifiedFieldNames) [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ (String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
tagNames)
          if Options -> Bool
rejectUnknownFields Options
options Bool -> Bool -> Bool
&& Bool -> Bool
not ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
unknown)
            then Text -> Either Text ToConstructor
forall a b. a -> Either a b
Left (Text -> Either Text ToConstructor)
-> Text -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text
"unknown field" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall (f :: * -> *) a. Foldable f => f a -> Text
plural [Text]
unknown Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
unknown
            else do
              let fields :: [FieldDef]
fields = [Text] -> [Text] -> [FieldDef]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
modifiedFieldNames [Text]
fieldTypes
              ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName ([(Maybe FieldDef, Value)] -> ToConstructor)
-> [(Maybe FieldDef, Value)] -> ToConstructor
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Maybe (Maybe FieldDef, Value))
-> [FieldDef] -> [(Maybe FieldDef, Value)]
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 Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
fieldName) Object
actualFields of
            Just Value
v -> (Maybe FieldDef, Value) -> Maybe (Maybe FieldDef, Value)
forall a. a -> Maybe a
Just (FieldDef -> Maybe FieldDef
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 (Maybe FieldDef, Value) -> Maybe (Maybe FieldDef, Value)
forall a. a -> Maybe a
Just (FieldDef -> Maybe FieldDef
forall a. a -> Maybe a
Just (Text
fieldName, Text
fieldType), Value
Null)
                else Maybe (Maybe FieldDef, Value)
forall a. Maybe a
Nothing
    Array Array
vs -> ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName ((Maybe FieldDef
forall a. Maybe a
Nothing,) (Value -> (Maybe FieldDef, Value))
-> [Value] -> [(Maybe FieldDef, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
vs)
    Value
_ -> ToConstructor -> Either Text ToConstructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ToConstructor -> Either Text ToConstructor)
-> ToConstructor -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ Text -> [(Maybe FieldDef, Value)] -> ToConstructor
ToConstructor Text
constructorName [(Maybe FieldDef
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 = [Either Text ToConstructor] -> Either Text ToConstructor
forall c. [Either Text c] -> Either Text c
foldEither ([Either Text ToConstructor] -> Either Text ToConstructor)
-> [Either Text ToConstructor] -> Either Text ToConstructor
forall a b. (a -> b) -> a -> b
$ ConstructorDef -> Either Text ToConstructor
f (ConstructorDef -> Either Text ToConstructor)
-> [ConstructorDef] -> [Either Text ToConstructor]
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 :: [Either Text c] -> Either Text c
foldEither [Either Text c]
es = do
  let ([Text]
ls, [c]
rs) = [Either Text c] -> ([Text], [c])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text c]
es
  case ([Text]
ls, [c]
rs) of
    ([], []) -> Text -> Either Text c
forall a b. a -> Either a b
Left Text
"no results"
    ([Text]
errors, []) -> Text -> Either Text c
forall a b. a -> Either a b
Left (Text -> [Text] -> Text
T.intercalate Text
" ->> " [Text]
errors)
    ([Text]
_, c
r : [c]
_) -> c -> Either Text 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 :: a -> Text
encodeAsText = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode

-- | Return a "s" if there are more than one element
plural :: Foldable f => f a -> Text
plural :: f a -> Text
plural f a
as = if [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
as) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then Text
"s" else Text
""