{-# LANGUAGE PolyKinds #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
module Generics.SOP.JSON (
    -- * Configuration
    JsonFieldName
  , JsonTagName
  , JsonOptions(..)
  , defaultJsonOptions
    -- * JSON view of a datatype
  , Tag(..)
  , JsonInfo(..)
  , jsonInfo
    -- * Generic functions
  , gtoJSON
  , gparseJSON
    -- * UpdateFromJSON and co
  , UpdateFromJSON(..)
  , gupdateFromJSON
  , replaceWithJSON
  , parseWith
    -- * Re-exports
  , ToJSON(..)
  , FromJSON(..)
  , Proxy(..)
  ) where

import Control.Arrow (first)
import Control.Monad
import Data.Aeson (ToJSON(..), FromJSON(..), Value(..))
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

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

type JsonFieldName = String
type JsonTagName   = String

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

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

defaultJsonOptions :: JsonOptions
defaultJsonOptions :: JsonOptions
defaultJsonOptions = JsonOptions :: (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
  }

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

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

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

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

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

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

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

jsonInfoFor :: forall xs. JsonOptions -> DatatypeName -> (ConstructorName -> Tag) -> ConstructorInfo xs -> JsonInfo xs
jsonInfoFor :: 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

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

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

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

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

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

gparseJSON :: forall a. (Generic a, HasDatatypeInfo a, All2 FromJSON (Code a))
           => JsonOptions -> Value -> Parser a
gparseJSON :: 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

    -- Necessary type annotation. Don't know why.
    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

-- | Given information about a constructor, check if the given value has the
-- right shape, and if so, return a product of (still encoded) values for
-- each of the arguments of the constructor
parseValues :: forall (xs :: [*]). 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

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

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

-- | For types that we can only replace "whole", rather than update field by field
replaceWithJSON :: FromJSON a => Value -> Parser (a -> a)
replaceWithJSON :: 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

-- | Conversely, for types that we can only parse if we have a starting point
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

-- Primitive types we can only replace whole
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

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

-- | Construct a function that updates a value of some record type, given
-- a JSON object with new values for some (or none, or all) of the fields
gupdateFromJSON :: forall a xs. (Generic a, HasDatatypeInfo a, All UpdateFromJSON xs, Code a ~ '[xs])
                => JsonOptions -> Value -> Parser (a -> a)
gupdateFromJSON :: 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)

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

-- | Given a product of keys in a particular order, and a list of values indexed
-- by keys, reorder the second list in the order specified by the first list.
-- Unexpected keys make the whole thing fail (outer monad @m@); missing keys
-- make the inner monad fail @m'@.
--
-- The following are instances of this type
--
-- > NP (K String) xs -> [(String, Value)] -> Parser (NP (K (Parser Value)) xs)
-- > NP (K String) xs -> [(String, Value)] -> Parser (NP (K (Maybe Value)) xs)
--
-- The first form is useful when all fields of a record need to be present;
-- the second when they are optional.
#if MIN_VERSION_base(4,13,0)
lineup :: (MonadFail m, MonadPlus m', MonadFail m', Eq a, Show a)
       => NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
#else
lineup :: (Monad m, MonadPlus m', Eq a, Show a)
       => NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)
#endif
lineup :: 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

-- | Error message for a missing key (used in lineup)
#if MIN_VERSION_base(4,13,0)
missingKey :: (MonadFail m, Show a) => a -> m b
#else
missingKey :: (Monad m, Show a) => a -> m b
#endif
missingKey :: 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 the first element that satisfies the predicate
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)]

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

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

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

#if MIN_VERSION_base(4,13,0)
withObject :: MonadFail m => String -> ([(String, Value)] -> m a) -> Value -> m a
#else
withObject :: Monad m => String -> ([(String, Value)] -> m a) -> Value -> m a
#endif
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 -- ^ The name of the type you are trying to parse.
             -> Value  -- ^ The actual value encountered.
             -> 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"