{-# LANGUAGE PolyKinds #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
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(..))
import Data.Aeson.Types (Parser, modifyFailure)
import Data.List (intercalate)
import Data.Text (Text)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Text
import qualified Data.Vector as Vector
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 :: [*] -> * 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 (Text, Value)) xs -> Value)
-> NP (K (Text, Value)) xs
-> K Value xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
Object
(Object -> Value)
-> (NP (K (Text, Value)) xs -> Object)
-> NP (K (Text, Value)) xs
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
([(Text, Value)] -> Object)
-> (NP (K (Text, Value)) xs -> [(Text, Value)])
-> NP (K (Text, Value)) xs
-> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K (Text, Value)) xs -> [(Text, 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 (Text, Value)) xs -> K Value xs)
-> NP (K (Text, Value)) xs -> K Value xs
forall a b. (a -> b) -> a -> b
$ Proxy ToJSON
-> (forall a.
ToJSON a =>
K DatatypeName a -> I a -> K (Text, Value) a)
-> Prod NP (K DatatypeName) xs
-> NP I xs
-> NP (K (Text, Value)) 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) -> (Text, Value) -> K (Text, Value) a
forall k a (b :: k). a -> K a b
K (DatatypeName -> Text
Text.pack DatatypeName
field, a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a)) Prod NP (K DatatypeName) xs
NP (K DatatypeName) xs
fields NP I xs
cs
#if __GLASGOW_HASKELL__ < 800
gtoJSON' _ _ = error "inaccessible"
#endif
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 :: [[*]]). 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 :: [[*]]) (xs :: [*]). 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 :: [*]). 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
#if __GLASGOW_HASKELL__ >= 710
{-# OVERLAPPABLE #-}
#endif
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
#if __GLASGOW_HASKELL__ >= 710
{-# OVERLAPPABLE #-}
#endif
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
#if __GLASGOW_HASKELL__ >= 710
{-# OVERLAPPING #-}
#endif
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"
#if __GLASGOW_HASKELL__ < 800
_ -> error "inaccessible"
#endif
gupdateRecord :: forall (xs :: [*]) (a :: *). 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
$ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(DatatypeName -> Text
Text.pack DatatypeName
t, 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
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
$ ((Text, Value) -> (DatatypeName, Value))
-> [(Text, Value)] -> [(DatatypeName, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> DatatypeName) -> (Text, Value) -> (DatatypeName, Value)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Text -> DatatypeName
Text.unpack) (Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList Object
obj)
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"