{-# LANGUAGE PolyKinds #-}

module Generics.SOP.JSON (
    -- * Configuration
    JsonFieldName
  , JsonTagName
  , JsonOptions(..)
  , defaultJsonOptions
    -- * JSON view of a datatype
  , Tag(..)
  , JsonInfo(..)
  , jsonInfo
    -- * Generic functions
  , gtoJSON
  , gparseJSON
    -- * UpdateFromJSON and co
  , UpdateFromJSON(..)
  , gupdateFromJSON
  , replaceWithJSON
  , parseWith
    -- * Re-exports
  , ToJSON(..)
  , FromJSON(..)
  , Proxy(..)
  ) where

import Control.Arrow (first)
import Control.Monad
import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), object, (.=))
import Data.Aeson.Types (Parser, modifyFailure)
import Data.Kind
import Data.List (intercalate)
import Data.String (fromString)
import Data.Text (Text)

import qualified Data.Text   as Text
import qualified Data.Vector as Vector

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key      as Key
import qualified Data.Aeson.KeyMap   as KeyMap
#else
import qualified Data.HashMap.Strict as HashMap
#endif

import Generics.SOP
import Generics.SOP.Lens
import Generics.SOP.Util.PartialResult

{-------------------------------------------------------------------------------
  Configuration
-------------------------------------------------------------------------------}

type JsonFieldName = String
type JsonTagName   = String

-- | JSON encoder/decoder configuration
data JsonOptions = JsonOptions {
    -- | Construct the name for JSON object fields (not for the tags that are
    -- used for sum-types, however)
    --
    -- The default just uses the name of the corresponding Haskell constructor
    JsonOptions -> DatatypeName -> DatatypeName -> DatatypeName
jsonFieldName :: DatatypeName -> FieldName -> JsonFieldName

    -- | Construct the name for a tag for sum-types.
    --
    -- The default just uses the name of the Haskell constructor.
  , JsonOptions -> DatatypeName -> DatatypeName
jsonTagName :: ConstructorName -> JsonTagName
  }

defaultJsonOptions :: JsonOptions
defaultJsonOptions :: JsonOptions
defaultJsonOptions = JsonOptions {
    jsonFieldName :: DatatypeName -> DatatypeName -> DatatypeName
jsonFieldName = forall a b. a -> b -> a
const forall a. a -> a
id
  , jsonTagName :: DatatypeName -> DatatypeName
jsonTagName   = forall a. a -> a
id
  }

{-------------------------------------------------------------------------------
  The JSON view of the world

  We translate the metadata independent of the encoding/decoding. This has two
  advantages: it makes the encoder and decoder clearer, as they (and their
  types!) are driven by this metadata; and two, we can give a readable
  description of this metadata to give the user a static description of what
  the JSON encoding of their datatype will look like.
-------------------------------------------------------------------------------}

-- | Constructor tag
--
-- For a datatype with a single constructor we do not need to tag values with
-- their constructor; but for a datatype with multiple constructors we do.
data Tag = NoTag | Tag JsonTagName

data JsonInfo :: [Type] -> Type where
  -- Constructor without arguments
  --
  -- In this we _just_ output the name of the constructor (as a string);
  -- we do this even if the datatype has only a single argument.
  JsonZero :: ConstructorName -> JsonInfo '[]

  -- Single argument constructor
  -- This includes newtypes (record or not), but not other record constructors
  --
  -- We just output the argument, discarding the wrapping datatype
  JsonOne :: Tag -> JsonInfo '[a]

  -- Multiple argument constructor, but not a record
  --
  -- We output the arguments as a JSON array
  JsonMultiple :: SListI xs => Tag -> JsonInfo xs

  -- Record constructor
  --
  -- We output the arguments as a JSON object (even if there is only one field)
  JsonRecord :: SListI xs => Tag -> NP (K String) xs -> JsonInfo xs

jsonInfoFor :: forall xs. JsonOptions -> DatatypeName -> (ConstructorName -> Tag) -> ConstructorInfo xs -> JsonInfo xs
jsonInfoFor :: forall (xs :: [*]).
JsonOptions
-> DatatypeName
-> (DatatypeName -> Tag)
-> ConstructorInfo xs
-> JsonInfo xs
jsonInfoFor JsonOptions
_    DatatypeName
_ DatatypeName -> Tag
tag (Infix DatatypeName
n Associativity
_ Fixity
_)   = forall (xs :: [*]). SListI xs => Tag -> JsonInfo xs
JsonMultiple (DatatypeName -> Tag
tag DatatypeName
n)
jsonInfoFor JsonOptions
_    DatatypeName
_ DatatypeName -> Tag
tag (Constructor DatatypeName
n) =
  case forall k (xs :: [k]). SListI xs => Shape xs
shape :: Shape xs of
    Shape xs
ShapeNil           -> DatatypeName -> JsonInfo '[]
JsonZero     DatatypeName
n
    ShapeCons Shape xs
ShapeNil -> forall a. Tag -> JsonInfo '[a]
JsonOne      (DatatypeName -> Tag
tag DatatypeName
n)
    Shape xs
_                  -> forall (xs :: [*]). SListI xs => Tag -> JsonInfo xs
JsonMultiple (DatatypeName -> Tag
tag DatatypeName
n)
jsonInfoFor JsonOptions
opts DatatypeName
d DatatypeName -> Tag
tag (Record DatatypeName
n NP FieldInfo xs
fields) =
    forall (xs :: [*]).
SListI xs =>
Tag -> NP (K DatatypeName) xs -> JsonInfo xs
JsonRecord (DatatypeName -> Tag
tag DatatypeName
n) (forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hliftA forall a. FieldInfo a -> K DatatypeName a
jfieldName NP FieldInfo xs
fields)
  where
    jfieldName :: FieldInfo a -> K String a
    jfieldName :: forall a. FieldInfo a -> K DatatypeName a
jfieldName (FieldInfo DatatypeName
name) = forall k a (b :: k). a -> K a b
K (JsonOptions -> DatatypeName -> DatatypeName -> DatatypeName
jsonFieldName JsonOptions
opts DatatypeName
d DatatypeName
name)

jsonInfo :: forall a. (HasDatatypeInfo a, SListI (Code a))
         => Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo :: forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo Proxy a
pa JsonOptions
opts =
  case forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo Proxy a
pa of
    Newtype {} -> forall a. Tag -> JsonInfo '[a]
JsonOne Tag
NoTag forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall {k} (a :: k -> *). NP a '[]
Nil
    d :: DatatypeInfo (Code a)
d@ADT {} ->
      forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hliftA
        (forall (xs :: [*]).
JsonOptions
-> DatatypeName
-> (DatatypeName -> Tag)
-> ConstructorInfo xs
-> JsonInfo xs
jsonInfoFor
          JsonOptions
opts
          (forall (xss :: [[*]]). DatatypeInfo xss -> DatatypeName
datatypeName DatatypeInfo (Code a)
d)
          (NP ConstructorInfo (Code a) -> DatatypeName -> Tag
tag (forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
constructorInfo DatatypeInfo (Code a)
d))
        )
        (forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
constructorInfo DatatypeInfo (Code a)
d)
  where
    tag :: NP ConstructorInfo (Code a) -> ConstructorName -> Tag
    tag :: NP ConstructorInfo (Code a) -> DatatypeName -> Tag
tag NP ConstructorInfo (Code a)
cs | ConstructorInfo x
_ :* NP ConstructorInfo xs
Nil <- NP ConstructorInfo (Code a)
cs = forall a b. a -> b -> a
const Tag
NoTag
           | Bool
otherwise      = DatatypeName -> Tag
Tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonOptions -> DatatypeName -> DatatypeName
jsonTagName JsonOptions
opts

{-------------------------------------------------------------------------------
  Encoder
-------------------------------------------------------------------------------}

gtoJSON :: forall a. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a))
        => JsonOptions -> a -> Value
gtoJSON :: forall a.
(Generic a, HasDatatypeInfo a, All2 ToJSON (Code a)) =>
JsonOptions -> a -> Value
gtoJSON JsonOptions
opts a
a =
  forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 Proxy (All ToJSON)
allpt forall (xs :: [*]).
All ToJSON xs =>
JsonInfo xs -> NP I xs -> K Value xs
gtoJSON' (forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) JsonOptions
opts)
                                      (forall {k} (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
unSOP forall a b. (a -> b) -> a -> b
$ forall a. Generic a => a -> Rep a
from a
a)

gtoJSON' :: All ToJSON xs => JsonInfo xs -> NP I xs -> K Value xs
gtoJSON' :: forall (xs :: [*]).
All ToJSON xs =>
JsonInfo xs -> NP I xs -> K Value xs
gtoJSON' (JsonZero DatatypeName
n) NP I xs
Nil =
    forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$ Text -> Value
String (DatatypeName -> Text
Text.pack DatatypeName
n)
gtoJSON' (JsonOne Tag
tag) (I x
a :* NP I xs
Nil) =
    forall {k} (a :: k). Tag -> Value -> K Value a
tagValue Tag
tag (forall a. ToJSON a => a -> Value
toJSON x
a)
gtoJSON' (JsonMultiple Tag
tag) NP I xs
cs =
    forall {k} (a :: k). Tag -> Value -> K Value a
tagValue Tag
tag
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Array
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
Vector.fromList
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcliftA Proxy ToJSON
pt (forall k a (b :: k). a -> K a b
K forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. I a -> a
unI)
  forall a b. (a -> b) -> a -> b
$ NP I xs
cs
gtoJSON' (JsonRecord Tag
tag NP (K DatatypeName) xs
fields) NP I xs
cs =
    forall {k} (a :: k). Tag -> Value -> K Value a
tagValue Tag
tag
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
object
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
  forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 Proxy ToJSON
pt (\(K DatatypeName
field) (I a
a) -> forall k a (b :: k). a -> K a b
K (forall a. IsString a => DatatypeName -> a
fromString DatatypeName
field forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
a)) NP (K DatatypeName) xs
fields NP I xs
cs

{-------------------------------------------------------------------------------
  Decoder

  NOTE: We use 'mzero' in various places, rather than failing with a more
  informative error message. The reason for this is that we constructor parsers
  for each of the constructors of a datatype, and then msum them together.
  If they all fail, we will get the error message from the last parser; if that
  says something like "missing field X" that might be very confusing if in fact
  we were trying to parse a different constructor altogether which may not
  even have a field X. If we want to fix this we have to restructure this
  so that we first find the right constructor, and then attempt to parse it.

  TODO: Maybe return a Parser of a Parser in parseValues?
-------------------------------------------------------------------------------}

gparseJSON :: forall a. (Generic a, HasDatatypeInfo a, All2 FromJSON (Code a))
           => JsonOptions -> Value -> Parser a
gparseJSON :: forall a.
(Generic a, HasDatatypeInfo a, All2 FromJSON (Code a)) =>
JsonOptions -> Value -> Parser a
gparseJSON JsonOptions
opts Value
v = forall a. Generic a => Rep a -> a
to forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (xss :: [[*]]).
All2 FromJSON xss =>
Value -> NP JsonInfo xss -> Parser (SOP I xss)
gparseJSON' Value
v (forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) JsonOptions
opts)

gparseJSON' :: forall (xss :: [[Type]]). All2 FromJSON xss
   => Value -> NP JsonInfo xss -> Parser (SOP I xss)
gparseJSON' :: forall (xss :: [[*]]).
All2 FromJSON xss =>
Value -> NP JsonInfo xss -> Parser (SOP I xss)
gparseJSON' Value
v NP JsonInfo xss
info = forall (m :: * -> *) a.
Monad m =>
([DatatypeName] -> m a) -> Partial m a -> m a
runPartial [DatatypeName] -> Parser (SOP I xss)
failWith
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
                   forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 Proxy (All FromJSON)
allpf (forall (xss :: [[*]]) (xs :: [*]).
All FromJSON xs =>
Value
-> JsonInfo xs
-> Injection (NP I) xss xs
-> K (Partial Parser (SOP I xss)) xs
parseConstructor Value
v) NP JsonInfo xss
info NP (Injection (NP I) xss) xss
injs
  where
    failWith :: [String] -> Parser (SOP I xss)
    failWith :: [DatatypeName] -> Parser (SOP I xss)
failWith []   = forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail forall a b. (a -> b) -> a -> b
$ DatatypeName
"Unknown error"
    failWith [DatatypeName]
errs = forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate DatatypeName
" or " [DatatypeName]
errs

    -- Necessary type annotation. Don't know why.
    injs :: NP (Injection (NP I) xss) xss
    injs :: NP (Injection (NP I) xss) xss
injs = forall {k} (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections

parseConstructor :: forall (xss :: [[Type]]) (xs :: [Type]). All FromJSON xs
                 => Value -> JsonInfo xs -> Injection (NP I) xss xs -> K (Partial Parser (SOP I xss)) xs
parseConstructor :: forall (xss :: [[*]]) (xs :: [*]).
All FromJSON xs =>
Value
-> JsonInfo xs
-> Injection (NP I) xss xs
-> K (Partial Parser (SOP I xss)) xs
parseConstructor Value
v JsonInfo xs
info (Fn NP I xs -> K (NS (NP I) xss) xs
inj) = forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$ do
    NP (K (Maybe DatatypeName, Value)) xs
vals <- forall (xs :: [*]).
SListI xs =>
JsonInfo xs
-> Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
parseValues JsonInfo xs
info Value
v
    NP I xs
prod <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {l} (h :: (* -> *) -> l -> *) (xs :: l) (f :: * -> *).
(SListIN h xs, SListIN (Prod h) xs, HSequence h, Applicative f) =>
h f xs -> f (h I xs)
hsequence forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcliftA Proxy FromJSON
pf forall a. FromJSON a => K (Maybe DatatypeName, Value) a -> Parser a
aux NP (K (Maybe DatatypeName, Value)) xs
vals
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). K a b -> a
unK (NP I xs -> K (NS (NP I) xss) xs
inj NP I xs
prod)
  where
    aux :: FromJSON a => K (Maybe String, Value) a -> Parser a
    aux :: forall a. FromJSON a => K (Maybe DatatypeName, Value) a -> Parser a
aux (K (Just DatatypeName
fName, Value
val)) = forall a. (DatatypeName -> DatatypeName) -> Parser a -> Parser a
modifyFailure (\DatatypeName
str -> DatatypeName
fName forall a. [a] -> [a] -> [a]
++ DatatypeName
": " forall a. [a] -> [a] -> [a]
++ DatatypeName
str) forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
    aux (K (Maybe DatatypeName
Nothing,    Value
val)) = forall a. FromJSON a => Value -> Parser a
parseJSON Value
val

-- | Given information about a constructor, check if the given value has the
-- right shape, and if so, return a product of (still encoded) values for
-- each of the arguments of the constructor
parseValues :: forall (xs :: [Type]). SListI xs
            => JsonInfo xs -> Value -> Partial Parser (NP (K (Maybe String, Value)) xs)
parseValues :: forall (xs :: [*]).
SListI xs =>
JsonInfo xs
-> Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
parseValues (JsonZero DatatypeName
n) =
  forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> (Text -> m a) -> Value -> m a
withText (DatatypeName
"Expected literal " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> DatatypeName
show DatatypeName
n) forall a b. (a -> b) -> a -> b
$ \Text
txt -> do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Text -> DatatypeName
Text.unpack Text
txt forall a. Eq a => a -> a -> Bool
== DatatypeName
n
    forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (a :: k -> *). NP a '[]
Nil
parseValues (JsonOne Tag
tag) =
  forall (m :: * -> *) a.
(Monad m, Functor m) =>
Tag -> (Value -> Partial m a) -> Value -> Partial m a
untag Tag
tag forall a b. (a -> b) -> a -> b
$ \Value
v ->
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a (b :: k). a -> K a b
K (forall a. Maybe a
Nothing, Value
v) forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall {k} (a :: k -> *). NP a '[]
Nil)
parseValues (JsonMultiple Tag
tag) =
  forall (m :: * -> *) a.
(Monad m, Functor m) =>
Tag -> (Value -> Partial m a) -> Value -> Partial m a
untag Tag
tag forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([Value] -> m a) -> Value -> m a
withArray DatatypeName
"Array" forall a b. (a -> b) -> a -> b
$ \[Value]
arr -> do
    case forall {k} (xs :: [k]) a. SListI xs => [a] -> Maybe (NP (K a) xs)
fromList (forall a b. (a -> b) -> [a] -> [b]
map (\Value
v -> (forall a. Maybe a
Nothing, Value
v)) [Value]
arr) of
      Just NP (K (Maybe DatatypeName, Value)) xs
values -> forall (m :: * -> *) a. Monad m => a -> m a
return NP (K (Maybe DatatypeName, Value)) xs
values
      Maybe (NP (K (Maybe DatatypeName, Value)) xs)
Nothing     -> forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail forall a b. (a -> b) -> a -> b
$ DatatypeName
"Got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> DatatypeName
show (forall (t :: * -> *) a. Foldable t => t a -> Fixity
length [Value]
arr) forall a. [a] -> [a] -> [a]
++ DatatypeName
"values, "
                         forall a. [a] -> [a] -> [a]
++ DatatypeName
"expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> DatatypeName
show (forall k (xs :: [k]) (proxy :: [k] -> *).
SListI xs =>
proxy xs -> Fixity
lengthSList (forall {k} (t :: k). Proxy t
Proxy :: Proxy xs))
parseValues (JsonRecord Tag
tag NP (K DatatypeName) xs
fields) =
  forall (m :: * -> *) a.
(Monad m, Functor m) =>
Tag -> (Value -> Partial m a) -> Value -> Partial m a
untag Tag
tag forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([(DatatypeName, Value)] -> m a) -> Value -> m a
withObject DatatypeName
"Object" forall a b. (a -> b) -> a -> b
$ \[(DatatypeName, Value)]
obj -> do
    NP (K Value) xs
values <- forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *) a.
(SListIN h xs, SListIN (Prod h) xs, Applicative f, HSequence h) =>
h (K (f a)) xs -> f (h (K a) xs)
hsequenceK forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} (m :: * -> *) (m' :: * -> *) a (xs :: [k]) b.
(MonadFail m, MonadPlus m', MonadFail m', Eq a, Show a) =>
NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
lineup NP (K DatatypeName) xs
fields [(DatatypeName, Value)]
obj
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(SListIN (Prod h) xs, HAp h, HAp (Prod h)) =>
(forall (a :: k). f a -> f' a -> f'' a)
-> Prod h f xs -> h f' xs -> h f'' xs
hliftA2 forall {k} {k} {k} {a} {b :: k} {b} {b :: k} {b :: k}.
K a b -> K b b -> K (Maybe a, b) b
pairFieldName NP (K DatatypeName) xs
fields NP (K Value) xs
values
  where
    pairFieldName :: K a b -> K b b -> K (Maybe a, b) b
pairFieldName (K a
x) (K b
y) = forall k a (b :: k). a -> K a b
K (forall a. a -> Maybe a
Just a
x, b
y)

untag :: (Monad m, Functor m) => Tag -> (Value -> Partial m a) -> Value -> Partial m a
untag :: forall (m :: * -> *) a.
(Monad m, Functor m) =>
Tag -> (Value -> Partial m a) -> Value -> Partial m a
untag Tag
NoTag   Value -> Partial m a
f = Value -> Partial m a
f
untag (Tag DatatypeName
n) Value -> Partial m a
f = forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([(DatatypeName, Value)] -> m a) -> Value -> m a
withObject DatatypeName
"Object" forall a b. (a -> b) -> a -> b
$ \[(DatatypeName, Value)]
obj ->
  case [(DatatypeName, Value)]
obj of
    [(DatatypeName
n', Value
v)] | DatatypeName
n' forall a. Eq a => a -> a -> Bool
== DatatypeName
n -> forall (f :: * -> *) a. Monad f => Partial f a -> Partial f a
partialResult forall a b. (a -> b) -> a -> b
$ Value -> Partial m a
f Value
v
    [(DatatypeName, Value)]
_                   -> forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail forall a b. (a -> b) -> a -> b
$ DatatypeName
"Expected tag " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> DatatypeName
show DatatypeName
n

{-------------------------------------------------------------------------------
  Updating values
-------------------------------------------------------------------------------}

-- | For some values we can support "updating" the value with a "partial"
-- JSON value; record types are the prime example (and the only one supported
-- by the generic function). For non-record types we typically can only
-- replace the value with a "complete" JSON value; in this case, we simply
-- ignore the old value (see 'replaceWithJSON'). Typical class instances will
-- look like
--
-- > instance UpdateFromJSON SomeRecordType where
-- >    updateFromJSON = gupdateFromJSON <jsonOptions>
--
-- or
--
-- > instance UpdateFromJSON SomeNonRecordType where
-- >    updateFromJSON = replaceWithJSON
--
-- NOTE: The generic function uses one-level lenses for the object fields.
-- We could generalize this to arbitrary paths, but then the type would change
-- to
--
-- > updateFromJSON :: Value -> Parser (a -> UpdateM a)
--
-- I.e., updating a value from JSON would, in general, involve a database
-- write.
class UpdateFromJSON a where
  updateFromJSON :: Value -> Parser (a -> a)

-- | For types that we can only replace "whole", rather than update field by field
replaceWithJSON :: FromJSON a => Value -> Parser (a -> a)
replaceWithJSON :: forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON Value
v = forall a. FromJSON a => Value -> Parser a
parseJSON Value
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
new -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \a
_old -> a
new

-- | Conversely, for types that we can only parse if we have a starting point
parseWith :: UpdateFromJSON a => a -> Value -> Parser a
parseWith :: forall a. UpdateFromJSON a => a -> Value -> Parser a
parseWith a
a = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> b) -> a -> b
$ a
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. UpdateFromJSON a => Value -> Parser (a -> a)
updateFromJSON

instance {-# OVERLAPPABLE #-} FromJSON a => UpdateFromJSON [a]
  where updateFromJSON :: Value -> Parser ([a] -> [a])
updateFromJSON = forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON

instance {-# OVERLAPPABLE #-} FromJSON a => UpdateFromJSON (Maybe a)
  where updateFromJSON :: Value -> Parser (Maybe a -> Maybe a)
updateFromJSON = forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON

-- Primitive types we can only replace whole
instance UpdateFromJSON Int      where updateFromJSON :: Value -> Parser (Fixity -> Fixity)
updateFromJSON = forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance UpdateFromJSON Double   where updateFromJSON :: Value -> Parser (Double -> Double)
updateFromJSON = forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance UpdateFromJSON Rational where updateFromJSON :: Value -> Parser (Rational -> Rational)
updateFromJSON = forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance UpdateFromJSON Bool     where updateFromJSON :: Value -> Parser (Bool -> Bool)
updateFromJSON = forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance UpdateFromJSON Text     where updateFromJSON :: Value -> Parser (Text -> Text)
updateFromJSON = forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON

instance {-# OVERLAPPING #-} UpdateFromJSON String
  where updateFromJSON :: Value -> Parser (DatatypeName -> DatatypeName)
updateFromJSON = forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON

{-------------------------------------------------------------------------------
  Generic instance for UpdateFromJSON
-------------------------------------------------------------------------------}

-- | Construct a function that updates a value of some record type, given
-- a JSON object with new values for some (or none, or all) of the fields
gupdateFromJSON :: forall a xs. (Generic a, HasDatatypeInfo a, All UpdateFromJSON xs, Code a ~ '[xs])
                => JsonOptions -> Value -> Parser (a -> a)
gupdateFromJSON :: forall a (xs :: [*]).
(Generic a, HasDatatypeInfo a, All UpdateFromJSON xs,
 Code a ~ '[xs]) =>
JsonOptions -> Value -> Parser (a -> a)
gupdateFromJSON JsonOptions
opts Value
v = do
  case forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) JsonOptions
opts of
    JsonRecord Tag
_ NP (K DatatypeName) x
fields :* NP JsonInfo xs
Nil -> forall (xs :: [*]) a.
All UpdateFromJSON xs =>
NP (K DatatypeName) xs
-> NP (GLens I I a) xs -> Value -> Parser (a -> a)
gupdateRecord NP (K DatatypeName) x
fields forall (r :: * -> *) (w :: * -> *) a (xs :: [*]).
(Generic a, Code a ~ '[xs], Monad r, Monad w) =>
NP (GLens r w a) xs
glenses Value
v
    JsonInfo x
_ :* NP JsonInfo xs
Nil -> forall a. HasCallStack => DatatypeName -> a
error DatatypeName
"cannot update non-record type"

gupdateRecord :: forall (xs :: [Type]) (a :: Type). All UpdateFromJSON xs
              => NP (K String) xs -> NP (GLens I I a) xs -> Value -> Parser (a -> a)
gupdateRecord :: forall (xs :: [*]) a.
All UpdateFromJSON xs =>
NP (K DatatypeName) xs
-> NP (GLens I I a) xs -> Value -> Parser (a -> a)
gupdateRecord NP (K DatatypeName) xs
fields NP (GLens I I a) xs
lenses = forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([(DatatypeName, Value)] -> m a) -> Value -> m a
withObject DatatypeName
"Object" forall a b. (a -> b) -> a -> b
$ \[(DatatypeName, Value)]
obj -> do
    NP (K (Maybe Value)) xs
values :: NP (K (Maybe Value)) xs <- forall {k} (m :: * -> *) (m' :: * -> *) a (xs :: [k]) b.
(MonadFail m, MonadPlus m', MonadFail m', Eq a, Show a) =>
NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
lineup NP (K DatatypeName) xs
fields [(DatatypeName, Value)]
obj
    [a -> a]
updates <- forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *) a.
(SListIN h xs, SListIN (Prod h) xs, Applicative f, HSequence h) =>
h (K (f a)) xs -> f (h (K a) xs)
hsequenceK (forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 Proxy UpdateFromJSON
pu forall b.
UpdateFromJSON b =>
K (Maybe Value) b -> GLens I I a b -> K (Parser (a -> a)) b
update NP (K (Maybe Value)) xs
values NP (GLens I I a) xs
lenses)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [a -> a]
updates
  where
    update :: forall b. UpdateFromJSON b
           => K (Maybe Value) b -> GLens I I a b -> K (Parser (a -> a)) b
    update :: forall b.
UpdateFromJSON b =>
K (Maybe Value) b -> GLens I I a b -> K (Parser (a -> a)) b
update (K Maybe Value
Nothing)  GLens I I a b
_ = forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
    update (K (Just Value
v)) GLens I I a b
l = forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$ do b -> b
f <- forall a. UpdateFromJSON a => Value -> Parser (a -> a)
updateFromJSON Value
v
                                   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \a
a -> forall a. I a -> a
unI forall a b. (a -> b) -> a -> b
$ forall (r :: * -> *) (w :: * -> *) a b.
GLens r w a b -> (b -> w b) -> a -> w a
modify GLens I I a b
l (forall a. a -> I a
I forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
f) a
a

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Given a product of keys in a particular order, and a list of values indexed
-- by keys, reorder the second list in the order specified by the first list.
-- Unexpected keys make the whole thing fail (outer monad @m@); missing keys
-- make the inner monad fail @m'@.
--
-- The following are instances of this type
--
-- > NP (K String) xs -> [(String, Value)] -> Parser (NP (K (Parser Value)) xs)
-- > NP (K String) xs -> [(String, Value)] -> Parser (NP (K (Maybe Value)) xs)
--
-- The first form is useful when all fields of a record need to be present;
-- the second when they are optional.
#if MIN_VERSION_base(4,13,0)
lineup :: (MonadFail m, MonadPlus m', MonadFail m', Eq a, Show a)
       => NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
#else
lineup :: (Monad m, MonadPlus m', Eq a, Show a)
       => NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
#endif
lineup :: forall {k} (m :: * -> *) (m' :: * -> *) a (xs :: [k]) b.
(MonadFail m, MonadPlus m', MonadFail m', Eq a, Show a) =>
NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
lineup NP (K a) xs
Nil []   = forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (a :: k -> *). NP a '[]
Nil
lineup NP (K a) xs
Nil [(a, b)]
vals = forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail forall a b. (a -> b) -> a -> b
$ DatatypeName
"Unexpected key(s): " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> DatatypeName
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, b)]
vals)
lineup (K a
k :* NP (K a) xs
ks) [] = do NP (K (m' b)) xs
bs <- forall {k} (m :: * -> *) (m' :: * -> *) a (xs :: [k]) b.
(MonadFail m, MonadPlus m', MonadFail m', Eq a, Show a) =>
NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
lineup NP (K a) xs
ks [] ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a (b :: k). a -> K a b
K (forall (m :: * -> *) a b. (MonadFail m, Show a) => a -> m b
missingKey a
k) forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (K (m' b)) xs
bs
lineup (K a
k :* NP (K a) xs
ks) [(a, b)]
vs =
  case forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
remove ((forall a. Eq a => a -> a -> Bool
== a
k) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(a, b)]
vs of
    Maybe ((a, b), [(a, b)])
Nothing            -> do NP (K (m' b)) xs
bs <- forall {k} (m :: * -> *) (m' :: * -> *) a (xs :: [k]) b.
(MonadFail m, MonadPlus m', MonadFail m', Eq a, Show a) =>
NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
lineup NP (K a) xs
ks [(a, b)]
vs  ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a (b :: k). a -> K a b
K (forall (m :: * -> *) a b. (MonadFail m, Show a) => a -> m b
missingKey a
k) forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (K (m' b)) xs
bs
    Just ((a
_, b
b), [(a, b)]
vs') -> do NP (K (m' b)) xs
bs <- forall {k} (m :: * -> *) (m' :: * -> *) a (xs :: [k]) b.
(MonadFail m, MonadPlus m', MonadFail m', Eq a, Show a) =>
NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
lineup NP (K a) xs
ks [(a, b)]
vs' ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a (b :: k). a -> K a b
K (forall (m :: * -> *) a. Monad m => a -> m a
return b
b)     forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (K (m' b)) xs
bs

-- | Error message for a missing key (used in lineup)
#if MIN_VERSION_base(4,13,0)
missingKey :: (MonadFail m, Show a) => a -> m b
#else
missingKey :: (Monad m, Show a) => a -> m b
#endif
missingKey :: forall (m :: * -> *) a b. (MonadFail m, Show a) => a -> m b
missingKey a
k = forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail forall a b. (a -> b) -> a -> b
$ DatatypeName
"missing key " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> DatatypeName
show a
k

-- | Remove the first element that satisfies the predicate
remove :: (a -> Bool) -> [a] -> Maybe (a, [a])
remove :: forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
remove a -> Bool
_ [] = forall a. Maybe a
Nothing
remove a -> Bool
f (a
x:[a]
xs) | a -> Bool
f a
x       = forall a. a -> Maybe a
Just (a
x, [a]
xs)
                | Bool
otherwise = do (a
y, [a]
ys) <- forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
remove a -> Bool
f [a]
xs ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
y, a
xforall a. a -> [a] -> [a]
:[a]
ys)

tagValue :: Tag -> Value -> K Value a
tagValue :: forall {k} (a :: k). Tag -> Value -> K Value a
tagValue Tag
NoTag   Value
v = forall k a (b :: k). a -> K a b
K Value
v
tagValue (Tag DatatypeName
t) Value
v = forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ [forall a. IsString a => DatatypeName -> a
fromString DatatypeName
t forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v]

{-------------------------------------------------------------------------------
  Constraint proxies
-------------------------------------------------------------------------------}

pt :: Proxy ToJSON
pt :: Proxy ToJSON
pt = forall {k} (t :: k). Proxy t
Proxy

allpt :: Proxy (All ToJSON)
allpt :: Proxy (All ToJSON)
allpt = forall {k} (t :: k). Proxy t
Proxy

pf :: Proxy FromJSON
pf :: Proxy FromJSON
pf = forall {k} (t :: k). Proxy t
Proxy

allpf :: Proxy (All FromJSON)
allpf :: Proxy (All FromJSON)
allpf = forall {k} (t :: k). Proxy t
Proxy

pu :: Proxy UpdateFromJSON
pu :: Proxy UpdateFromJSON
pu = forall {k} (t :: k). Proxy t
Proxy

{-------------------------------------------------------------------------------
  Adaptation of some of Aeson's combinators
-------------------------------------------------------------------------------}

#if MIN_VERSION_base(4,13,0)
withObject :: MonadFail m => String -> ([(String, Value)] -> m a) -> Value -> m a
#else
withObject :: Monad m => String -> ([(String, Value)] -> m a) -> Value -> m a
#endif
#if MIN_VERSION_aeson(2,0,0)
withObject :: forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([(DatatypeName, Value)] -> m a) -> Value -> m a
withObject DatatypeName
_        [(DatatypeName, Value)] -> m a
f (Object Object
obj) = [(DatatypeName, Value)] -> m a
f forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Key -> DatatypeName
Key.toString) (forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
obj)
#else
withObject _        f (Object obj) = f $ map (first Text.unpack) (HashMap.toList obj)
#endif
withObject DatatypeName
expected [(DatatypeName, Value)] -> m a
_ Value
v            = forall (m :: * -> *) a. MonadFail m => DatatypeName -> Value -> m a
typeMismatch DatatypeName
expected Value
v

#if MIN_VERSION_base(4,13,0)
withText :: MonadFail m => String -> (Text -> m a) -> Value -> m a
#else
withText :: Monad m => String -> (Text -> m a) -> Value -> m a
#endif
withText :: forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> (Text -> m a) -> Value -> m a
withText DatatypeName
_        Text -> m a
f (String Text
txt) = Text -> m a
f Text
txt
withText DatatypeName
expected Text -> m a
_ Value
v            = forall (m :: * -> *) a. MonadFail m => DatatypeName -> Value -> m a
typeMismatch DatatypeName
expected Value
v

#if MIN_VERSION_base(4,13,0)
withArray :: MonadFail m => String -> ([Value] -> m a) -> Value -> m a
#else
withArray :: Monad m => String -> ([Value] -> m a) -> Value -> m a
#endif
withArray :: forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([Value] -> m a) -> Value -> m a
withArray DatatypeName
_         [Value] -> m a
f (Array Array
arr) = [Value] -> m a
f forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
Vector.toList Array
arr
withArray DatatypeName
expected  [Value] -> m a
_ Value
v           = forall (m :: * -> *) a. MonadFail m => DatatypeName -> Value -> m a
typeMismatch DatatypeName
expected Value
v

#if MIN_VERSION_base(4,13,0)
typeMismatch :: MonadFail m
#else
typeMismatch :: Monad m
#endif
             => String -- ^ The name of the type you are trying to parse.
             -> Value  -- ^ The actual value encountered.
             -> m a
typeMismatch :: forall (m :: * -> *) a. MonadFail m => DatatypeName -> Value -> m a
typeMismatch DatatypeName
expected Value
actual =
    forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail forall a b. (a -> b) -> a -> b
$ DatatypeName
"when expecting a " forall a. [a] -> [a] -> [a]
++ DatatypeName
expected forall a. [a] -> [a] -> [a]
++ DatatypeName
", encountered " forall a. [a] -> [a] -> [a]
++ DatatypeName
name forall a. [a] -> [a] -> [a]
++
           DatatypeName
" instead"
  where
    name :: DatatypeName
name = case Value
actual of
             Object Object
_ -> DatatypeName
"Object"
             Array Array
_  -> DatatypeName
"Array"
             String Text
_ -> DatatypeName
"String"
             Number Scientific
_ -> DatatypeName
"Number"
             Bool Bool
_   -> DatatypeName
"Boolean"
             Value
Null     -> DatatypeName
"Null"