{-# 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 :: (DatatypeName -> DatatypeName -> DatatypeName)
-> (DatatypeName -> DatatypeName) -> JsonOptions
JsonOptions {
jsonFieldName :: DatatypeName -> DatatypeName -> DatatypeName
jsonFieldName = (DatatypeName -> DatatypeName)
-> DatatypeName -> DatatypeName -> DatatypeName
forall a b. a -> b -> a
const DatatypeName -> DatatypeName
forall a. a -> a
id
, jsonTagName :: DatatypeName -> DatatypeName
jsonTagName = DatatypeName -> DatatypeName
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 :: JsonOptions
-> DatatypeName
-> (DatatypeName -> Tag)
-> ConstructorInfo xs
-> JsonInfo xs
jsonInfoFor JsonOptions
_ DatatypeName
_ DatatypeName -> Tag
tag (Infix DatatypeName
n Associativity
_ Fixity
_) = Tag -> JsonInfo xs
forall (xs :: [*]). SListI xs => Tag -> JsonInfo xs
JsonMultiple (DatatypeName -> Tag
tag DatatypeName
n)
jsonInfoFor JsonOptions
_ DatatypeName
_ DatatypeName -> Tag
tag (Constructor DatatypeName
n) =
case Shape xs
forall k (xs :: [k]). SListI xs => Shape xs
shape :: Shape xs of
Shape xs
ShapeNil -> DatatypeName -> JsonInfo '[]
JsonZero DatatypeName
n
ShapeCons Shape xs
ShapeNil -> Tag -> JsonInfo '[x]
forall a. Tag -> JsonInfo '[a]
JsonOne (DatatypeName -> Tag
tag DatatypeName
n)
Shape xs
_ -> Tag -> JsonInfo 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) =
Tag -> NP (K DatatypeName) xs -> JsonInfo xs
forall (xs :: [*]).
SListI xs =>
Tag -> NP (K DatatypeName) xs -> JsonInfo xs
JsonRecord (DatatypeName -> Tag
tag DatatypeName
n) ((forall a. FieldInfo a -> K DatatypeName a)
-> NP FieldInfo xs -> NP (K DatatypeName) xs
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 :: FieldInfo a -> K DatatypeName a
jfieldName (FieldInfo DatatypeName
name) = DatatypeName -> K DatatypeName a
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 :: Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo Proxy a
pa JsonOptions
opts =
case Proxy a -> DatatypeInfo (Code a)
forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo Proxy a
pa of
Newtype {} -> Tag -> JsonInfo '[x]
forall a. Tag -> JsonInfo '[a]
JsonOne Tag
NoTag JsonInfo '[x] -> NP JsonInfo '[] -> NP JsonInfo '[ '[x]]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP JsonInfo '[]
forall k (a :: k -> *). NP a '[]
Nil
d :: DatatypeInfo (Code a)
d@ADT {} ->
(forall (a :: [*]). ConstructorInfo a -> JsonInfo a)
-> NP ConstructorInfo (Code a) -> NP JsonInfo (Code a)
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
(JsonOptions
-> DatatypeName
-> (DatatypeName -> Tag)
-> ConstructorInfo a
-> JsonInfo a
forall (xs :: [*]).
JsonOptions
-> DatatypeName
-> (DatatypeName -> Tag)
-> ConstructorInfo xs
-> JsonInfo xs
jsonInfoFor
JsonOptions
opts
(DatatypeInfo (Code a) -> DatatypeName
forall (xss :: [[*]]). DatatypeInfo xss -> DatatypeName
datatypeName DatatypeInfo (Code a)
d)
(NP ConstructorInfo (Code a) -> DatatypeName -> Tag
tag (DatatypeInfo (Code a) -> NP ConstructorInfo (Code a)
forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
constructorInfo DatatypeInfo (Code a)
d))
)
(DatatypeInfo (Code a) -> NP ConstructorInfo (Code a)
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 = Tag -> DatatypeName -> Tag
forall a b. a -> b -> a
const Tag
NoTag
| Bool
otherwise = DatatypeName -> Tag
Tag (DatatypeName -> Tag)
-> (DatatypeName -> DatatypeName) -> DatatypeName -> 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 :: JsonOptions -> a -> Value
gtoJSON JsonOptions
opts a
a =
NS (K Value) (Code a) -> CollapseTo NS Value
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K Value) (Code a) -> CollapseTo NS Value)
-> NS (K Value) (Code a) -> CollapseTo NS Value
forall a b. (a -> b) -> a -> b
$ Proxy (All ToJSON)
-> (forall (a :: [*]).
All ToJSON a =>
JsonInfo a -> NP I a -> K Value a)
-> Prod NS JsonInfo (Code a)
-> NS (NP I) (Code a)
-> NS (K Value) (Code a)
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 (a :: [*]).
All ToJSON a =>
JsonInfo a -> NP I a -> K Value a
gtoJSON' (Proxy a -> JsonOptions -> NP JsonInfo (Code a)
forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) JsonOptions
opts)
(SOP I (Code a) -> NS (NP I) (Code a)
forall k (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
unSOP (SOP I (Code a) -> NS (NP I) (Code a))
-> SOP I (Code a) -> NS (NP I) (Code a)
forall a b. (a -> b) -> a -> b
$ a -> SOP I (Code a)
forall a. Generic a => a -> Rep a
from a
a)
gtoJSON' :: All ToJSON xs => JsonInfo xs -> NP I xs -> K Value xs
gtoJSON' :: JsonInfo xs -> NP I xs -> K Value xs
gtoJSON' (JsonZero DatatypeName
n) NP I xs
Nil =
Value -> K Value xs
forall k a (b :: k). a -> K a b
K (Value -> K Value xs) -> Value -> K Value xs
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) =
Tag -> Value -> K Value xs
forall k (a :: k). Tag -> Value -> K Value a
tagValue Tag
tag (x -> Value
forall a. ToJSON a => a -> Value
toJSON x
a)
gtoJSON' (JsonMultiple Tag
tag) NP I xs
cs =
Tag -> Value -> K Value xs
forall k (a :: k). Tag -> Value -> K Value a
tagValue Tag
tag
(Value -> K Value xs)
-> (NP I xs -> Value) -> NP I xs -> K Value xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Array
(Array -> Value) -> (NP I xs -> Array) -> NP I xs -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList
([Value] -> Array) -> (NP I xs -> [Value]) -> NP I xs -> Array
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K Value) xs -> [Value]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
(NP (K Value) xs -> [Value])
-> (NP I xs -> NP (K Value) xs) -> NP I xs -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy ToJSON
-> (forall a. ToJSON a => I a -> K Value a)
-> NP I xs
-> NP (K Value) xs
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 (Value -> K Value a
forall k a (b :: k). a -> K a b
K (Value -> K Value a) -> (I a -> Value) -> I a -> K Value a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON (a -> Value) -> (I a -> a) -> I a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I a -> a
forall a. I a -> a
unI)
(NP I xs -> K Value xs) -> NP I xs -> K Value xs
forall a b. (a -> b) -> a -> b
$ NP I xs
cs
gtoJSON' (JsonRecord Tag
tag NP (K DatatypeName) xs
fields) NP I xs
cs =
Tag -> Value -> K Value xs
forall k (a :: k). Tag -> Value -> K Value a
tagValue Tag
tag
(Value -> K Value xs)
-> (NP (K Pair) xs -> Value) -> NP (K Pair) xs -> K Value xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
object
([Pair] -> Value)
-> (NP (K Pair) xs -> [Pair]) -> NP (K Pair) xs -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K Pair) xs -> [Pair]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
(NP (K Pair) xs -> K Value xs) -> NP (K Pair) xs -> K Value xs
forall a b. (a -> b) -> a -> b
$ Proxy ToJSON
-> (forall a. ToJSON a => K DatatypeName a -> I a -> K Pair a)
-> Prod NP (K DatatypeName) xs
-> NP I xs
-> NP (K Pair) xs
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 field) (I a) -> Pair -> K Pair a
forall k a (b :: k). a -> K a b
K (DatatypeName -> Key
forall a. IsString a => DatatypeName -> a
fromString DatatypeName
field Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
a)) Prod NP (K DatatypeName) xs
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 :: JsonOptions -> Value -> Parser a
gparseJSON JsonOptions
opts Value
v = SOP I (Code a) -> a
forall a. Generic a => Rep a -> a
to (SOP I (Code a) -> a) -> Parser (SOP I (Code a)) -> Parser a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Value -> NP JsonInfo (Code a) -> Parser (SOP I (Code a))
forall (xss :: [[*]]).
All2 FromJSON xss =>
Value -> NP JsonInfo xss -> Parser (SOP I xss)
gparseJSON' Value
v (Proxy a -> JsonOptions -> NP JsonInfo (Code a)
forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo (Proxy a
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' :: Value -> NP JsonInfo xss -> Parser (SOP I xss)
gparseJSON' Value
v NP JsonInfo xss
info = ([DatatypeName] -> Parser (SOP I xss))
-> Partial Parser (SOP I xss) -> Parser (SOP I xss)
forall (m :: * -> *) a.
Monad m =>
([DatatypeName] -> m a) -> Partial m a -> m a
runPartial [DatatypeName] -> Parser (SOP I xss)
failWith
(Partial Parser (SOP I xss) -> Parser (SOP I xss))
-> (NP (K (Partial Parser (SOP I xss))) xss
-> Partial Parser (SOP I xss))
-> NP (K (Partial Parser (SOP I xss))) xss
-> Parser (SOP I xss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Partial Parser (SOP I xss)] -> Partial Parser (SOP I xss)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
([Partial Parser (SOP I xss)] -> Partial Parser (SOP I xss))
-> (NP (K (Partial Parser (SOP I xss))) xss
-> [Partial Parser (SOP I xss)])
-> NP (K (Partial Parser (SOP I xss))) xss
-> Partial Parser (SOP I xss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K (Partial Parser (SOP I xss))) xss
-> [Partial Parser (SOP I xss)]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
(NP (K (Partial Parser (SOP I xss))) xss -> Parser (SOP I xss))
-> NP (K (Partial Parser (SOP I xss))) xss -> Parser (SOP I xss)
forall a b. (a -> b) -> a -> b
$ Proxy (All FromJSON)
-> (forall (a :: [*]).
All FromJSON a =>
JsonInfo a
-> Injection (NP I) xss a -> K (Partial Parser (SOP I xss)) a)
-> Prod NP JsonInfo xss
-> NP (Injection (NP I) xss) xss
-> NP (K (Partial Parser (SOP I xss))) xss
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 (Value
-> JsonInfo a
-> Injection (NP I) xss a
-> K (Partial Parser (SOP I xss)) a
forall (xss :: [[*]]) (xs :: [*]).
All FromJSON xs =>
Value
-> JsonInfo xs
-> Injection (NP I) xss xs
-> K (Partial Parser (SOP I xss)) xs
parseConstructor Value
v) Prod NP JsonInfo xss
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 [] = DatatypeName -> Parser (SOP I xss)
forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail (DatatypeName -> Parser (SOP I xss))
-> DatatypeName -> Parser (SOP I xss)
forall a b. (a -> b) -> a -> b
$ DatatypeName
"Unknown error"
failWith [DatatypeName]
errs = DatatypeName -> Parser (SOP I xss)
forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail (DatatypeName -> Parser (SOP I xss))
-> DatatypeName -> Parser (SOP I xss)
forall a b. (a -> b) -> a -> b
$ DatatypeName -> [DatatypeName] -> DatatypeName
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 = NP (Injection (NP I) xss) xss
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 :: 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) = Partial Parser (SOP I xss) -> K (Partial Parser (SOP I xss)) xs
forall k a (b :: k). a -> K a b
K (Partial Parser (SOP I xss) -> K (Partial Parser (SOP I xss)) xs)
-> Partial Parser (SOP I xss) -> K (Partial Parser (SOP I xss)) xs
forall a b. (a -> b) -> a -> b
$ do
NP (K (Maybe DatatypeName, Value)) xs
vals <- JsonInfo xs
-> Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
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 <- Parser (NP I xs) -> Partial Parser (NP I xs)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser (NP I xs) -> Partial Parser (NP I xs))
-> (NP Parser xs -> Parser (NP I xs))
-> NP Parser xs
-> Partial Parser (NP I xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP Parser xs -> Parser (NP I xs)
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 (NP Parser xs -> Partial Parser (NP I xs))
-> NP Parser xs -> Partial Parser (NP I xs)
forall a b. (a -> b) -> a -> b
$ Proxy FromJSON
-> (forall a.
FromJSON a =>
K (Maybe DatatypeName, Value) a -> Parser a)
-> NP (K (Maybe DatatypeName, Value)) xs
-> NP Parser xs
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
SOP I xss -> Partial Parser (SOP I xss)
forall (m :: * -> *) a. Monad m => a -> m a
return (SOP I xss -> Partial Parser (SOP I xss))
-> SOP I xss -> Partial Parser (SOP I xss)
forall a b. (a -> b) -> a -> b
$ NS (NP I) xss -> SOP I xss
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP (NS (NP I) xss -> SOP I xss) -> NS (NP I) xss -> SOP I xss
forall a b. (a -> b) -> a -> b
$ K (NS (NP I) xss) xs -> NS (NP I) xss
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 :: K (Maybe DatatypeName, Value) a -> Parser a
aux (K (Just DatatypeName
fName, Value
val)) = (DatatypeName -> DatatypeName) -> Parser a -> Parser a
forall a. (DatatypeName -> DatatypeName) -> Parser a -> Parser a
modifyFailure (\DatatypeName
str -> DatatypeName
fName DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
": " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
str) (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
aux (K (Maybe DatatypeName
Nothing, Value
val)) = Value -> Parser a
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 :: JsonInfo xs
-> Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
parseValues (JsonZero DatatypeName
n) =
DatatypeName
-> (Text
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[]))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[])
forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> (Text -> m a) -> Value -> m a
withText (DatatypeName
"Expected literal " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName -> DatatypeName
forall a. Show a => a -> DatatypeName
show DatatypeName
n) ((Text -> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[]))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[]))
-> (Text
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[]))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[])
forall a b. (a -> b) -> a -> b
$ \Text
txt -> do
Bool -> Partial Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Partial Parser ()) -> Bool -> Partial Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> DatatypeName
Text.unpack Text
txt DatatypeName -> DatatypeName -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeName
n
NP (K (Maybe DatatypeName, Value)) '[]
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[])
forall (m :: * -> *) a. Monad m => a -> m a
return NP (K (Maybe DatatypeName, Value)) '[]
forall k (a :: k -> *). NP a '[]
Nil
parseValues (JsonOne Tag
tag) =
Tag
-> (Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[a]))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[a])
forall (m :: * -> *) a.
(Monad m, Functor m) =>
Tag -> (Value -> Partial m a) -> Value -> Partial m a
untag Tag
tag ((Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[a]))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[a]))
-> (Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[a]))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[a])
forall a b. (a -> b) -> a -> b
$ \Value
v ->
NP (K (Maybe DatatypeName, Value)) '[a]
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) '[a])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe DatatypeName, Value) -> K (Maybe DatatypeName, Value) a
forall k a (b :: k). a -> K a b
K (Maybe DatatypeName
forall a. Maybe a
Nothing, Value
v) K (Maybe DatatypeName, Value) a
-> NP (K (Maybe DatatypeName, Value)) '[]
-> NP (K (Maybe DatatypeName, Value)) '[a]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (K (Maybe DatatypeName, Value)) '[]
forall k (a :: k -> *). NP a '[]
Nil)
parseValues (JsonMultiple Tag
tag) =
Tag
-> (Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall (m :: * -> *) a.
(Monad m, Functor m) =>
Tag -> (Value -> Partial m a) -> Value -> Partial m a
untag Tag
tag ((Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> (Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall a b. (a -> b) -> a -> b
$ DatatypeName
-> ([Value]
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([Value] -> m a) -> Value -> m a
withArray DatatypeName
"Array" (([Value]
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> ([Value]
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall a b. (a -> b) -> a -> b
$ \[Value]
arr -> do
case [(Maybe DatatypeName, Value)]
-> Maybe (NP (K (Maybe DatatypeName, Value)) xs)
forall k (xs :: [k]) a. SListI xs => [a] -> Maybe (NP (K a) xs)
fromList ((Value -> (Maybe DatatypeName, Value))
-> [Value] -> [(Maybe DatatypeName, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\Value
v -> (Maybe DatatypeName
forall a. Maybe a
Nothing, Value
v)) [Value]
arr) of
Just NP (K (Maybe DatatypeName, Value)) xs
values -> NP (K (Maybe DatatypeName, Value)) xs
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall (m :: * -> *) a. Monad m => a -> m a
return NP (K (Maybe DatatypeName, Value)) xs
values
Maybe (NP (K (Maybe DatatypeName, Value)) xs)
Nothing -> DatatypeName
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail (DatatypeName
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> DatatypeName
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall a b. (a -> b) -> a -> b
$ DatatypeName
"Got " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ Fixity -> DatatypeName
forall a. Show a => a -> DatatypeName
show ([Value] -> Fixity
forall (t :: * -> *) a. Foldable t => t a -> Fixity
length [Value]
arr) DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
"values, "
DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
"expected " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ Fixity -> DatatypeName
forall a. Show a => a -> DatatypeName
show (Proxy xs -> Fixity
forall k (xs :: [k]) (proxy :: [k] -> *).
SListI xs =>
proxy xs -> Fixity
lengthSList (Proxy xs
forall k (t :: k). Proxy t
Proxy :: Proxy xs))
parseValues (JsonRecord Tag
tag NP (K DatatypeName) xs
fields) =
Tag
-> (Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall (m :: * -> *) a.
(Monad m, Functor m) =>
Tag -> (Value -> Partial m a) -> Value -> Partial m a
untag Tag
tag ((Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> (Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall a b. (a -> b) -> a -> b
$ DatatypeName
-> ([(DatatypeName, Value)]
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([(DatatypeName, Value)] -> m a) -> Value -> m a
withObject DatatypeName
"Object" (([(DatatypeName, Value)]
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value -> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> ([(DatatypeName, Value)]
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> Value
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall a b. (a -> b) -> a -> b
$ \[(DatatypeName, Value)]
obj -> do
NP (K Value) xs
values <- NP (K (Partial Parser Value)) xs
-> Partial Parser (NP (K Value) xs)
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 (NP (K (Partial Parser Value)) xs
-> Partial Parser (NP (K Value) xs))
-> Partial Parser (NP (K (Partial Parser Value)) xs)
-> Partial Parser (NP (K Value) xs)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NP (K DatatypeName) xs
-> [(DatatypeName, Value)]
-> Partial Parser (NP (K (Partial Parser 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
NP (K (Maybe DatatypeName, Value)) xs
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall (m :: * -> *) a. Monad m => a -> m a
return (NP (K (Maybe DatatypeName, Value)) xs
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs))
-> NP (K (Maybe DatatypeName, Value)) xs
-> Partial Parser (NP (K (Maybe DatatypeName, Value)) xs)
forall a b. (a -> b) -> a -> b
$ (forall a.
K DatatypeName a -> K Value a -> K (Maybe DatatypeName, Value) a)
-> Prod NP (K DatatypeName) xs
-> NP (K Value) xs
-> NP (K (Maybe DatatypeName, Value)) xs
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 a.
K DatatypeName a -> K Value a -> K (Maybe DatatypeName, Value) a
forall k k k a (b :: k) b (b :: k) (b :: k).
K a b -> K b b -> K (Maybe a, b) b
pairFieldName Prod NP (K DatatypeName) xs
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) = (Maybe a, b) -> K (Maybe a, b) b
forall k a (b :: k). a -> K a b
K (a -> Maybe a
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 :: 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 = DatatypeName
-> ([(DatatypeName, Value)] -> Partial m a) -> Value -> Partial m a
forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([(DatatypeName, Value)] -> m a) -> Value -> m a
withObject DatatypeName
"Object" (([(DatatypeName, Value)] -> Partial m a) -> Value -> Partial m a)
-> ([(DatatypeName, Value)] -> Partial m a) -> Value -> Partial m a
forall a b. (a -> b) -> a -> b
$ \[(DatatypeName, Value)]
obj ->
case [(DatatypeName, Value)]
obj of
[(DatatypeName
n', Value
v)] | DatatypeName
n' DatatypeName -> DatatypeName -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeName
n -> Partial m a -> Partial m a
forall (f :: * -> *) a. Monad f => Partial f a -> Partial f a
partialResult (Partial m a -> Partial m a) -> Partial m a -> Partial m a
forall a b. (a -> b) -> a -> b
$ Value -> Partial m a
f Value
v
[(DatatypeName, Value)]
_ -> DatatypeName -> Partial m a
forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail (DatatypeName -> Partial m a) -> DatatypeName -> Partial m a
forall a b. (a -> b) -> a -> b
$ DatatypeName
"Expected tag " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName -> DatatypeName
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 :: Value -> Parser (a -> a)
replaceWithJSON Value
v = Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v Parser a -> (a -> Parser (a -> a)) -> Parser (a -> a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
new -> (a -> a) -> Parser (a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> a) -> Parser (a -> a)) -> (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$ \a
_old -> a
new
parseWith :: UpdateFromJSON a => a -> Value -> Parser a
parseWith :: a -> Value -> Parser a
parseWith a
a = ((a -> a) -> a) -> Parser (a -> a) -> Parser a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
a) (Parser (a -> a) -> Parser a)
-> (Value -> Parser (a -> a)) -> Value -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser (a -> a)
forall a. UpdateFromJSON a => Value -> Parser (a -> a)
updateFromJSON
instance {-# OVERLAPPABLE #-} FromJSON a => UpdateFromJSON [a]
where updateFromJSON :: Value -> Parser ([a] -> [a])
updateFromJSON = Value -> Parser ([a] -> [a])
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 = Value -> Parser (Maybe a -> Maybe a)
forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance UpdateFromJSON Int where updateFromJSON :: Value -> Parser (Fixity -> Fixity)
updateFromJSON = Value -> Parser (Fixity -> Fixity)
forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance UpdateFromJSON Double where updateFromJSON :: Value -> Parser (Double -> Double)
updateFromJSON = Value -> Parser (Double -> Double)
forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance UpdateFromJSON Rational where updateFromJSON :: Value -> Parser (Rational -> Rational)
updateFromJSON = Value -> Parser (Rational -> Rational)
forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance UpdateFromJSON Bool where updateFromJSON :: Value -> Parser (Bool -> Bool)
updateFromJSON = Value -> Parser (Bool -> Bool)
forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance UpdateFromJSON Text where updateFromJSON :: Value -> Parser (Text -> Text)
updateFromJSON = Value -> Parser (Text -> Text)
forall a. FromJSON a => Value -> Parser (a -> a)
replaceWithJSON
instance {-# OVERLAPPING #-} UpdateFromJSON String
where updateFromJSON :: Value -> Parser (DatatypeName -> DatatypeName)
updateFromJSON = Value -> Parser (DatatypeName -> DatatypeName)
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 :: JsonOptions -> Value -> Parser (a -> a)
gupdateFromJSON JsonOptions
opts Value
v = do
case Proxy a -> JsonOptions -> NP JsonInfo (Code a)
forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) JsonOptions
opts of
JsonRecord Tag
_ NP (K DatatypeName) x
fields :* NP JsonInfo xs
Nil -> NP (K DatatypeName) x
-> NP (GLens (->) (->) a) x -> Value -> Parser (a -> a)
forall (xs :: [*]) a.
All UpdateFromJSON xs =>
NP (K DatatypeName) xs
-> NP (GLens (->) (->) a) xs -> Value -> Parser (a -> a)
gupdateRecord NP (K DatatypeName) x
fields NP (GLens (->) (->) a) x
forall (r :: * -> * -> *) (w :: * -> * -> *) a (xs :: [*]).
(Generic a, Code a ~ '[xs], Arrow r, ArrowApply w) =>
NP (GLens r w a) xs
glenses Value
v
JsonInfo x
_ :* NP JsonInfo xs
Nil -> DatatypeName -> Parser (a -> a)
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 (->) (->) a) xs -> Value -> Parser (a -> a)
gupdateRecord :: NP (K DatatypeName) xs
-> NP (GLens (->) (->) a) xs -> Value -> Parser (a -> a)
gupdateRecord NP (K DatatypeName) xs
fields NP (GLens (->) (->) a) xs
lenses = DatatypeName
-> ([(DatatypeName, Value)] -> Parser (a -> a))
-> Value
-> Parser (a -> a)
forall (m :: * -> *) a.
MonadFail m =>
DatatypeName -> ([(DatatypeName, Value)] -> m a) -> Value -> m a
withObject DatatypeName
"Object" (([(DatatypeName, Value)] -> Parser (a -> a))
-> Value -> Parser (a -> a))
-> ([(DatatypeName, Value)] -> Parser (a -> a))
-> Value
-> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$ \[(DatatypeName, Value)]
obj -> do
NP (K (Maybe Value)) xs
values :: NP (K (Maybe Value)) xs <- NP (K DatatypeName) xs
-> [(DatatypeName, Value)] -> Parser (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 <- NP (K (a -> a)) xs -> [a -> a]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K (a -> a)) xs -> [a -> a])
-> Parser (NP (K (a -> a)) xs) -> Parser [a -> a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` NP (K (Parser (a -> a))) xs -> Parser (NP (K (a -> a)) xs)
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 (Proxy UpdateFromJSON
-> (forall a.
UpdateFromJSON a =>
K (Maybe Value) a -> GLens (->) (->) a a -> K (Parser (a -> a)) a)
-> Prod NP (K (Maybe Value)) xs
-> NP (GLens (->) (->) a) xs
-> NP (K (Parser (a -> a))) xs
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 a.
UpdateFromJSON a =>
K (Maybe Value) a -> GLens (->) (->) a a -> K (Parser (a -> a)) a
update Prod NP (K (Maybe Value)) xs
NP (K (Maybe Value)) xs
values NP (GLens (->) (->) a) xs
lenses)
(a -> a) -> Parser (a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> a) -> Parser (a -> a)) -> (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$ ((a -> a) -> (a -> a) -> a -> a) -> (a -> a) -> [a -> a] -> a -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> a
forall a. a -> a
id [a -> a]
updates
where
update :: forall b. UpdateFromJSON b
=> K (Maybe Value) b -> GLens (->) (->) a b -> K (Parser (a -> a)) b
update :: K (Maybe Value) b -> GLens (->) (->) a b -> K (Parser (a -> a)) b
update (K Maybe Value
Nothing) GLens (->) (->) a b
_ = Parser (a -> a) -> K (Parser (a -> a)) b
forall k a (b :: k). a -> K a b
K (Parser (a -> a) -> K (Parser (a -> a)) b)
-> Parser (a -> a) -> K (Parser (a -> a)) b
forall a b. (a -> b) -> a -> b
$ (a -> a) -> Parser (a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
forall a. a -> a
id
update (K (Just Value
v)) GLens (->) (->) a b
l = Parser (a -> a) -> K (Parser (a -> a)) b
forall k a (b :: k). a -> K a b
K (Parser (a -> a) -> K (Parser (a -> a)) b)
-> Parser (a -> a) -> K (Parser (a -> a)) b
forall a b. (a -> b) -> a -> b
$ do b -> b
f <- Value -> Parser (b -> b)
forall a. UpdateFromJSON a => Value -> Parser (a -> a)
updateFromJSON Value
v
(a -> a) -> Parser (a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> a) -> Parser (a -> a)) -> (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$ \a
a -> GLens (->) (->) a b -> (b -> b, a) -> a
forall (r :: * -> * -> *) (w :: * -> * -> *) a b.
GLens r w a b -> w (w b b, a) a
modify GLens (->) (->) a b
l (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 :: NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
lineup NP (K a) xs
Nil [] = NP (K (m' b)) '[] -> m (NP (K (m' b)) '[])
forall (m :: * -> *) a. Monad m => a -> m a
return NP (K (m' b)) '[]
forall k (a :: k -> *). NP a '[]
Nil
lineup NP (K a) xs
Nil [(a, b)]
vals = DatatypeName -> m (NP (K (m' b)) xs)
forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail (DatatypeName -> m (NP (K (m' b)) xs))
-> DatatypeName -> m (NP (K (m' b)) xs)
forall a b. (a -> b) -> a -> b
$ DatatypeName
"Unexpected key(s): " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ [a] -> DatatypeName
forall a. Show a => a -> DatatypeName
show (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
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 <- NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) 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 a) xs
ks [] ; NP (K (m' b)) (x : xs) -> m (NP (K (m' b)) (x : xs))
forall (m :: * -> *) a. Monad m => a -> m a
return (NP (K (m' b)) (x : xs) -> m (NP (K (m' b)) (x : xs)))
-> NP (K (m' b)) (x : xs) -> m (NP (K (m' b)) (x : xs))
forall a b. (a -> b) -> a -> b
$ m' b -> K (m' b) x
forall k a (b :: k). a -> K a b
K (a -> m' b
forall (m :: * -> *) a b. (MonadFail m, Show a) => a -> m b
missingKey a
k) K (m' b) x -> NP (K (m' b)) xs -> NP (K (m' b)) (x : xs)
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 ((a, b) -> Bool) -> [(a, b)] -> Maybe ((a, b), [(a, b)])
forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
remove ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
k) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst) [(a, b)]
vs of
Maybe ((a, b), [(a, b)])
Nothing -> do NP (K (m' b)) xs
bs <- NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) 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 a) xs
ks [(a, b)]
vs ; NP (K (m' b)) (x : xs) -> m (NP (K (m' b)) (x : xs))
forall (m :: * -> *) a. Monad m => a -> m a
return (NP (K (m' b)) (x : xs) -> m (NP (K (m' b)) (x : xs)))
-> NP (K (m' b)) (x : xs) -> m (NP (K (m' b)) (x : xs))
forall a b. (a -> b) -> a -> b
$ m' b -> K (m' b) x
forall k a (b :: k). a -> K a b
K (a -> m' b
forall (m :: * -> *) a b. (MonadFail m, Show a) => a -> m b
missingKey a
k) K (m' b) x -> NP (K (m' b)) xs -> NP (K (m' b)) (x : xs)
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 <- NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) 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 a) xs
ks [(a, b)]
vs' ; NP (K (m' b)) (x : xs) -> m (NP (K (m' b)) (x : xs))
forall (m :: * -> *) a. Monad m => a -> m a
return (NP (K (m' b)) (x : xs) -> m (NP (K (m' b)) (x : xs)))
-> NP (K (m' b)) (x : xs) -> m (NP (K (m' b)) (x : xs))
forall a b. (a -> b) -> a -> b
$ m' b -> K (m' b) x
forall k a (b :: k). a -> K a b
K (b -> m' b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b) K (m' b) x -> NP (K (m' b)) xs -> NP (K (m' b)) (x : xs)
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 :: a -> m b
missingKey a
k = DatatypeName -> m b
forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail (DatatypeName -> m b) -> DatatypeName -> m b
forall a b. (a -> b) -> a -> b
$ DatatypeName
"missing key " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ a -> DatatypeName
forall a. Show a => a -> DatatypeName
show a
k
remove :: (a -> Bool) -> [a] -> Maybe (a, [a])
remove :: (a -> Bool) -> [a] -> Maybe (a, [a])
remove a -> Bool
_ [] = Maybe (a, [a])
forall a. Maybe a
Nothing
remove a -> Bool
f (a
x:[a]
xs) | a -> Bool
f a
x = (a, [a]) -> Maybe (a, [a])
forall a. a -> Maybe a
Just (a
x, [a]
xs)
| Bool
otherwise = do (a
y, [a]
ys) <- (a -> Bool) -> [a] -> Maybe (a, [a])
forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
remove a -> Bool
f [a]
xs ; (a, [a]) -> Maybe (a, [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
y, a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
tagValue :: Tag -> Value -> K Value a
tagValue :: Tag -> Value -> K Value a
tagValue Tag
NoTag Value
v = Value -> K Value a
forall k a (b :: k). a -> K a b
K Value
v
tagValue (Tag DatatypeName
t) Value
v = Value -> K Value a
forall k a (b :: k). a -> K a b
K (Value -> K Value a) -> Value -> K Value a
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [DatatypeName -> Key
forall a. IsString a => DatatypeName -> a
fromString DatatypeName
t Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v]
pt :: Proxy ToJSON
pt :: Proxy ToJSON
pt = Proxy ToJSON
forall k (t :: k). Proxy t
Proxy
allpt :: Proxy (All ToJSON)
allpt :: Proxy (All ToJSON)
allpt = Proxy (All ToJSON)
forall k (t :: k). Proxy t
Proxy
pf :: Proxy FromJSON
pf :: Proxy FromJSON
pf = Proxy FromJSON
forall k (t :: k). Proxy t
Proxy
allpf :: Proxy (All FromJSON)
allpf :: Proxy (All FromJSON)
allpf = Proxy (All FromJSON)
forall k (t :: k). Proxy t
Proxy
pu :: Proxy UpdateFromJSON
pu :: Proxy UpdateFromJSON
pu = Proxy UpdateFromJSON
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 :: DatatypeName -> ([(DatatypeName, Value)] -> m a) -> Value -> m a
withObject DatatypeName
_ [(DatatypeName, Value)] -> m a
f (Object Object
obj) = [(DatatypeName, Value)] -> m a
f ([(DatatypeName, Value)] -> m a) -> [(DatatypeName, Value)] -> m a
forall a b. (a -> b) -> a -> b
$ (Pair -> (DatatypeName, Value))
-> [Pair] -> [(DatatypeName, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> DatatypeName) -> Pair -> (DatatypeName, Value)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Key -> DatatypeName
Key.toString) (Object -> [Pair]
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 = DatatypeName -> Value -> m a
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 :: 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 = DatatypeName -> Value -> m a
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 :: DatatypeName -> ([Value] -> m a) -> Value -> m a
withArray DatatypeName
_ [Value] -> m a
f (Array Array
arr) = [Value] -> m a
f ([Value] -> m a) -> [Value] -> m a
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
arr
withArray DatatypeName
expected [Value] -> m a
_ Value
v = DatatypeName -> Value -> m a
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 :: DatatypeName -> Value -> m a
typeMismatch DatatypeName
expected Value
actual =
DatatypeName -> m a
forall (m :: * -> *) a. MonadFail m => DatatypeName -> m a
fail (DatatypeName -> m a) -> DatatypeName -> m a
forall a b. (a -> b) -> a -> b
$ DatatypeName
"when expecting a " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
expected DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
", encountered " DatatypeName -> DatatypeName -> DatatypeName
forall a. [a] -> [a] -> [a]
++ DatatypeName
name DatatypeName -> DatatypeName -> DatatypeName
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"