{-# LANGUAGE PolyKinds #-}
module Generics.SOP.JSON (
JsonFieldName
, JsonTagName
, JsonOptions(..)
, defaultJsonOptions
, Tag(..)
, JsonInfo(..)
, jsonInfo
, gtoJSON
, gparseJSON
, UpdateFromJSON(..)
, gupdateFromJSON
, replaceWithJSON
, parseWith
, 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
type JsonFieldName = String
type JsonTagName = String
data JsonOptions = JsonOptions {
JsonOptions -> DatatypeName -> DatatypeName -> DatatypeName
jsonFieldName :: DatatypeName -> FieldName -> JsonFieldName
, 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
}
data Tag = NoTag | Tag JsonTagName
data JsonInfo :: [Type] -> Type where
JsonZero :: ConstructorName -> JsonInfo '[]
JsonOne :: Tag -> JsonInfo '[a]
JsonMultiple :: SListI xs => Tag -> JsonInfo xs
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
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
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
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
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
class UpdateFromJSON a where
updateFromJSON :: Value -> Parser (a -> a)
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
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
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
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
#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
#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 :: (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]
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
#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
-> Value
-> 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"