{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE ImportQualifiedPost   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE UndecidableInstances  #-}

-- | 
-- This module provides support for using "Dovetail" with @aeson@.
--
-- For certain appliations, it is useful to use JSON as an input or output format,
-- but to let the user decide the exact schema for that JSON data. The simplest way
-- to let the user have control over this from Dovetail is to use PureScript's
-- types to define the serialization functions. That is, just like with generic
-- deriving, our serializers will be inferred from our types. But with Dovetail,
-- we will use the inferred *PureScript* type to synthesize a serializer, not the
-- Haskell types.
--
-- The @query-json@ example in the repository is a good example. The user's program
-- defines a function from JSON inputs to JSON outputs, and the types and format 
-- of the input and output data are determined by the type of the user's program,
-- which is allowed to be a function between any two *serializable* PureScript types.
--
-- Serializable types include primitives (strings, chars, ints, numbers and booleans),
-- records and arrays of other serializable types, and the special 'Nullable' type
-- which is provided for handling serialization of nullable JSON substructures.
--
-- Note: you do not need to use this module if you are working with JSON whose
-- structure is known ahead of time. In that case, you can simply use Dovetail 
-- directly to marshall Haskell data back and forth over the FFI boundary, and
-- Aeson for serialization. This module should be used when the structure is
-- not known ahead of time, because it is controlled by the user.
--
-- The user's program may have a polymorphic type signature. This can happen
-- easily: for example, if the user's program in the @query-json@ example is a
-- record accessor such as @_.foo@, then it will have a polymorphic (indeed, also
-- row-polymorphic) type. We cannot know what JSON data the user will pass as an
-- input to a polymorphic program, and we can't synthesize a specific type for 
-- that input data. So, this module also provides the 'UnknownJSON' type for
-- handling these cases, which is simply a wrapper around Aeson's 'Aeson.Value'
-- type. Since a polymorphic program cannot inspect a value with a polymorphic
-- type (thanks to parametricity), it is safe to make this data accessible to
-- the program in this way. However, this also means that such data will not
-- be visible in the debugger (and instead, will appear as an abstract @<foreign>@ 
-- value).

module Dovetail.Aeson 
  ( 
  -- * Serializable types    
  -- ** Evaluation
    evalJSON
  
  -- ** Type reification
  , Serializable
  , reify 
  
  -- ** Supporting code
  , stdlib
  , Nullable(..)
  , UnknownJSON(..)
  ) where

import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.Dynamic qualified as Dynamic
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Proxy (Proxy(..))
import Data.Reflection (reifySymbol)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Vector (Vector)
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import Dovetail
import Dovetail.Evaluate qualified as Evaluate
import Language.PureScript qualified as P
import Language.PureScript.Names qualified as Names
import Language.PureScript.Label qualified as Label

-- | Evaluate a PureScript expression from source, returning its value as 
-- encoded JSON.
--
-- This function is a convenient counterpart to 'eval' which can be useful 
-- for applications whose output format is JSON.
evalJSON 
  :: Maybe ModuleName 
  -> Text
  -> Interpret ctx Aeson.Value
evalJSON :: Maybe ModuleName -> Text -> Interpret ctx Value
evalJSON Maybe ModuleName
defaultModuleName Text
expr = do
  (Eval ctx (Value ctx)
val, SourceType
ty) <- Maybe ModuleName
-> Text -> Interpret ctx (Eval ctx (Value ctx), SourceType)
forall ctx a.
ToValueRHS ctx a =>
Maybe ModuleName -> Text -> Interpret ctx (a, SourceType)
eval Maybe ModuleName
defaultModuleName Text
expr
  Eval ctx Value -> Interpret ctx Value
forall ctx a. Eval ctx a -> Interpret ctx a
liftEval (Eval ctx Value -> Interpret ctx Value)
-> Eval ctx Value -> Interpret ctx Value
forall a b. (a -> b) -> a -> b
$ SourceType
-> (forall a. Serializable ctx a => Proxy a -> Eval ctx Value)
-> Eval ctx Value
forall ctx r.
SourceType
-> (forall a. Serializable ctx a => Proxy a -> Eval ctx r)
-> Eval ctx r
reify SourceType
ty \(Proxy a
_ :: Proxy a) -> 
    a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (a -> Value) -> Eval ctx a -> Eval ctx Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ToValue ctx a => Value ctx -> Eval ctx a
forall ctx a. ToValue ctx a => Value ctx -> Eval ctx a
fromValue @_ @a (Value ctx -> Eval ctx a) -> Eval ctx (Value ctx) -> Eval ctx a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Eval ctx (Value ctx)
val)

-- | A constraint synonym for the constraint our reified types will satisfy:
-- serialization via 'Aeson.ToJSON', deserialization via 'Aeson.FromJSON', and
-- transport via the FFI, via 'Evaluate.ToValue'.
--
-- This synonym is provided just for the convenience of tidying up the type
-- signatures.
type Serializable ctx a =
  ( Aeson.FromJSON a
  , Aeson.ToJSON a
  , Evaluate.ToValue ctx a
  )

-- | Reify a PureScript 'P.SourceType' as a Haskell type which supports
-- transport via the FFI using 'Evaluate.ToValue', and JSON serialization using
-- 'Aeson.ToJSON' and 'Aeson.FromJSON'.
--
-- Just as @DeriveGeneric@ allows us to derive a type-directed serialization
-- method based on the Haskell type of our values, this function allows us to
-- derive a serialization method based on the *PureScript* type of a value.
--
-- This can be useful in more advanced use cases where 'evalJSON' won't suffice.
-- For example, if we want to take data as input from a JSON structure,
-- then we can reify the PureScript type of the domain of a PureScript function.
reify 
  :: forall ctx r
   . P.SourceType 
  -- ^ The PureScript type we wish to reify, for example, from the return value of 'eval'.
  -> (forall a. Serializable ctx a => Proxy a -> Eval ctx r)
  -- ^ The continuation, which will receive a 'Proxy' for the type which has been
  -- reified.
  -> Eval ctx r
reify :: SourceType
-> (forall a. Serializable ctx a => Proxy a -> Eval ctx r)
-> Eval ctx r
reify = SourceType
-> (forall a. Serializable ctx a => Proxy a -> Eval ctx r)
-> Eval ctx r
go where
  go :: P.SourceType 
     -> (forall a. Serializable ctx a => Proxy a -> Eval ctx r)
     -> Eval ctx r
  go :: SourceType
-> (forall a. Serializable ctx a => Proxy a -> Eval ctx r)
-> Eval ctx r
go (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Int"))) forall a. Serializable ctx a => Proxy a -> Eval ctx r
f =
    Proxy Integer -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy Integer
forall k (t :: k). Proxy t
Proxy :: Proxy Integer)
  go (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Number"))) forall a. Serializable ctx a => Proxy a -> Eval ctx r
f =
    Proxy Double -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy Double
forall k (t :: k). Proxy t
Proxy :: Proxy Double)
  go (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"String"))) forall a. Serializable ctx a => Proxy a -> Eval ctx r
f =
    Proxy Text -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy Text
forall k (t :: k). Proxy t
Proxy :: Proxy Text)
  go (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Char"))) forall a. Serializable ctx a => Proxy a -> Eval ctx r
f =
    Proxy Char -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy Char
forall k (t :: k). Proxy t
Proxy :: Proxy Char)
  go (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Boolean"))) forall a. Serializable ctx a => Proxy a -> Eval ctx r
f =
    Proxy Bool -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy Bool
forall k (t :: k). Proxy t
Proxy :: Proxy Bool)
  go P.TypeVar{} forall a. Serializable ctx a => Proxy a -> Eval ctx r
f =
    Proxy UnknownJSON -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy UnknownJSON
forall k (t :: k). Proxy t
Proxy :: Proxy UnknownJSON) 
  go (P.TypeApp SourceAnn
_ (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Record"))) SourceType
ty) forall a. Serializable ctx a => Proxy a -> Eval ctx r
f = do
    let ([RowListItem SourceAnn]
knownFields, SourceType
unknownFields) = SourceType -> ([RowListItem SourceAnn], SourceType)
forall a. Type a -> ([RowListItem a], Type a)
P.rowToSortedList SourceType
ty
    case SourceType
unknownFields of
      P.KindApp SourceAnn
_ P.REmpty{} SourceType
_ ->
        [RowListItem SourceAnn]
-> (forall a.
    (ToJSONObject a, FromJSONObject a, ToObject ctx a) =>
    Proxy a -> Eval ctx r)
-> Eval ctx r
goRecord [RowListItem SourceAnn]
knownFields (\(Proxy a
Proxy :: Proxy xs) -> Proxy (Record a) -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy (Record a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Record xs)))
      P.TypeVar{} ->
        [RowListItem SourceAnn]
-> (forall a.
    (ToJSONObject a, FromJSONObject a, ToObject ctx a) =>
    Proxy a -> Eval ctx r)
-> Eval ctx r
goRecord [RowListItem SourceAnn]
knownFields (\(Proxy a
Proxy :: Proxy xs) -> Proxy (OpenRecord a) -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy (OpenRecord a)
forall k (t :: k). Proxy t
Proxy :: Proxy (OpenRecord xs)))
      SourceType
_ ->
        EvaluationErrorType ctx -> Eval ctx r
forall x (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> EvaluationErrorType ctx
forall ctx. Text -> EvaluationErrorType ctx
Evaluate.OtherError Text
"record type is not serializable")
  go (P.TypeApp SourceAnn
_ (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Array"))) SourceType
ty) forall a. Serializable ctx a => Proxy a -> Eval ctx r
f =
    SourceType
-> (forall a. Serializable ctx a => Proxy a -> Eval ctx r)
-> Eval ctx r
go SourceType
ty (\(Proxy a
Proxy :: Proxy a) -> Proxy (Vector a) -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy (Vector a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Vector a)))
  go (P.TypeApp SourceAnn
_ (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"JSON")) (P.ProperName Text
"Nullable"))) SourceType
ty) forall a. Serializable ctx a => Proxy a -> Eval ctx r
f =
    SourceType
-> (forall a. Serializable ctx a => Proxy a -> Eval ctx r)
-> Eval ctx r
go SourceType
ty (\(Proxy a
Proxy :: Proxy a) -> Proxy (Nullable a) -> Eval ctx r
forall a. Serializable ctx a => Proxy a -> Eval ctx r
f (Proxy (Nullable a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Nullable a))) 
  go SourceType
_  forall a. Serializable ctx a => Proxy a -> Eval ctx r
_ =
    EvaluationErrorType ctx -> Eval ctx r
forall x (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> EvaluationErrorType ctx
forall ctx. Text -> EvaluationErrorType ctx
Evaluate.OtherError Text
"type is not serializable")

  goRecord
    :: [P.RowListItem P.SourceAnn]
    -> (forall a. (ToJSONObject a, FromJSONObject a, ToObject ctx a) => Proxy a -> Eval ctx r)
    -> Eval ctx r
  goRecord :: [RowListItem SourceAnn]
-> (forall a.
    (ToJSONObject a, FromJSONObject a, ToObject ctx a) =>
    Proxy a -> Eval ctx r)
-> Eval ctx r
goRecord [] forall a.
(ToJSONObject a, FromJSONObject a, ToObject ctx a) =>
Proxy a -> Eval ctx r
f = 
    Proxy Nil -> Eval ctx r
forall a.
(ToJSONObject a, FromJSONObject a, ToObject ctx a) =>
Proxy a -> Eval ctx r
f (Proxy Nil
forall k (t :: k). Proxy t
Proxy :: Proxy Nil)
  goRecord (P.RowListItem SourceAnn
_ (Label.Label PSString
k) SourceType
x : [RowListItem SourceAnn]
xs) forall a.
(ToJSONObject a, FromJSONObject a, ToObject ctx a) =>
Proxy a -> Eval ctx r
f = do
    Text
t <- PSString -> Eval ctx Text
forall ctx. PSString -> Eval ctx Text
Evaluate.evalPSString PSString
k
    String
-> (forall (n :: Symbol). KnownSymbol n => Proxy n -> Eval ctx r)
-> Eval ctx r
forall r.
String
-> (forall (n :: Symbol). KnownSymbol n => Proxy n -> r) -> r
reifySymbol (Text -> String
Text.unpack Text
t) \(Proxy n
Proxy :: Proxy k) ->
      SourceType
-> (forall a. Serializable ctx a => Proxy a -> Eval ctx r)
-> Eval ctx r
go SourceType
x \(Proxy a
Proxy :: Proxy x) ->
        [RowListItem SourceAnn]
-> (forall a.
    (ToJSONObject a, FromJSONObject a, ToObject ctx a) =>
    Proxy a -> Eval ctx r)
-> Eval ctx r
goRecord [RowListItem SourceAnn]
xs \(Proxy a
Proxy :: Proxy xs) ->
          Proxy (Cons n a a) -> Eval ctx r
forall a.
(ToJSONObject a, FromJSONObject a, ToObject ctx a) =>
Proxy a -> Eval ctx r
f (Proxy (Cons n a a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Cons k x xs))

data OpenRecord xs = OpenRecord
  { OpenRecord xs -> xs
_knownFields :: xs
  , OpenRecord xs -> HashMap Text UnknownJSON
_allFields :: HashMap Text UnknownJSON
  }

instance FromJSONObject xs => Aeson.FromJSON (OpenRecord xs) where
  parseJSON :: Value -> Parser (OpenRecord xs)
parseJSON = String
-> (Object -> Parser (OpenRecord xs))
-> Value
-> Parser (OpenRecord xs)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"object" \Object
o -> 
    xs -> HashMap Text UnknownJSON -> OpenRecord xs
forall xs. xs -> HashMap Text UnknownJSON -> OpenRecord xs
OpenRecord (xs -> HashMap Text UnknownJSON -> OpenRecord xs)
-> Parser xs -> Parser (HashMap Text UnknownJSON -> OpenRecord xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser xs
forall a. FromJSONObject a => Object -> Parser a
parseJSONObject Object
o Parser (HashMap Text UnknownJSON -> OpenRecord xs)
-> Parser (HashMap Text UnknownJSON) -> Parser (OpenRecord xs)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text UnknownJSON -> Parser (HashMap Text UnknownJSON)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value -> UnknownJSON) -> Object -> HashMap Text UnknownJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> UnknownJSON
UnknownJSON Object
o)
  
instance ToJSONObject xs => Aeson.ToJSON (OpenRecord xs) where
  toJSON :: OpenRecord xs -> Value
toJSON (OpenRecord xs
xs HashMap Text UnknownJSON
o) = Object -> Value
Aeson.Object (xs -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject xs
xs Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> (UnknownJSON -> Value) -> HashMap Text UnknownJSON -> Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnknownJSON -> Value
getUnknownJSON HashMap Text UnknownJSON
o)

instance ToObject ctx xs => ToValue ctx (OpenRecord xs) where
  toValue :: OpenRecord xs -> Value ctx
toValue (OpenRecord xs
xs HashMap Text UnknownJSON
o) = HashMap Text (Value ctx) -> Value ctx
forall ctx. HashMap Text (Value ctx) -> Value ctx
Evaluate.Object (xs -> HashMap Text (Value ctx)
forall ctx a. ToObject ctx a => a -> HashMap Text (Value ctx)
toObject xs
xs HashMap Text (Value ctx)
-> HashMap Text (Value ctx) -> HashMap Text (Value ctx)
forall a. Semigroup a => a -> a -> a
<> (UnknownJSON -> Value ctx)
-> HashMap Text UnknownJSON -> HashMap Text (Value ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnknownJSON -> Value ctx
forall ctx a. ToValue ctx a => a -> Value ctx
toValue HashMap Text UnknownJSON
o)
  
  fromValue :: Value ctx -> Eval ctx (OpenRecord xs)
fromValue (Evaluate.Object HashMap Text (Value ctx)
o) = 
    let isUnknownJSON :: Value ctx -> Bool
isUnknownJSON (Evaluate.Foreign Dynamic
dyn)
          | Just{} <- Dynamic -> Maybe Value
forall a. Typeable a => Dynamic -> Maybe a
Dynamic.fromDynamic @Aeson.Value Dynamic
dyn = Bool
True
        isUnknownJSON Value ctx
_ = Bool
False
     in xs -> HashMap Text UnknownJSON -> OpenRecord xs
forall xs. xs -> HashMap Text UnknownJSON -> OpenRecord xs
OpenRecord (xs -> HashMap Text UnknownJSON -> OpenRecord xs)
-> Eval ctx xs
-> Eval ctx (HashMap Text UnknownJSON -> OpenRecord xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (Value ctx) -> Eval ctx xs
forall ctx a.
ToObject ctx a =>
HashMap Text (Value ctx) -> Eval ctx a
fromObject HashMap Text (Value ctx)
o Eval ctx (HashMap Text UnknownJSON -> OpenRecord xs)
-> Eval ctx (HashMap Text UnknownJSON) -> Eval ctx (OpenRecord xs)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value ctx -> Eval ctx UnknownJSON)
-> HashMap Text (Value ctx) -> Eval ctx (HashMap Text UnknownJSON)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value ctx -> Eval ctx UnknownJSON
forall ctx a. ToValue ctx a => Value ctx -> Eval ctx a
fromValue ((Value ctx -> Bool)
-> HashMap Text (Value ctx) -> HashMap Text (Value ctx)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter Value ctx -> Bool
forall ctx. Value ctx -> Bool
isUnknownJSON HashMap Text (Value ctx)
o)
  fromValue Value ctx
other = 
    EvaluationErrorType ctx -> Eval ctx (OpenRecord xs)
forall x (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value ctx -> EvaluationErrorType ctx
forall ctx. Text -> Value ctx -> EvaluationErrorType ctx
Evaluate.TypeMismatch Text
"object" Value ctx
other)

newtype Record xs = Record { Record xs -> xs
getRecord :: xs }

instance FromJSONObject xs => Aeson.FromJSON (Record xs) where
  parseJSON :: Value -> Parser (Record xs)
parseJSON = (xs -> Record xs) -> Parser xs -> Parser (Record xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap xs -> Record xs
forall xs. xs -> Record xs
Record (Parser xs -> Parser (Record xs))
-> (Value -> Parser xs) -> Value -> Parser (Record xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Object -> Parser xs) -> Value -> Parser xs
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"object" Object -> Parser xs
forall a. FromJSONObject a => Object -> Parser a
parseJSONObject
  
instance ToJSONObject xs => Aeson.ToJSON (Record xs) where
  toJSON :: Record xs -> Value
toJSON (Record xs
xs) = Object -> Value
Aeson.Object (xs -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject xs
xs)

instance ToObject ctx xs => ToValue ctx (Record xs) where
  toValue :: Record xs -> Value ctx
toValue = HashMap Text (Value ctx) -> Value ctx
forall ctx. HashMap Text (Value ctx) -> Value ctx
Evaluate.Object (HashMap Text (Value ctx) -> Value ctx)
-> (Record xs -> HashMap Text (Value ctx))
-> Record xs
-> Value ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. xs -> HashMap Text (Value ctx)
forall ctx a. ToObject ctx a => a -> HashMap Text (Value ctx)
toObject (xs -> HashMap Text (Value ctx))
-> (Record xs -> xs) -> Record xs -> HashMap Text (Value ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record xs -> xs
forall xs. Record xs -> xs
getRecord
  
  fromValue :: Value ctx -> Eval ctx (Record xs)
fromValue (Evaluate.Object HashMap Text (Value ctx)
o) = 
    xs -> Record xs
forall xs. xs -> Record xs
Record (xs -> Record xs) -> Eval ctx xs -> Eval ctx (Record xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (Value ctx) -> Eval ctx xs
forall ctx a.
ToObject ctx a =>
HashMap Text (Value ctx) -> Eval ctx a
fromObject HashMap Text (Value ctx)
o 
  fromValue Value ctx
other = 
    EvaluationErrorType ctx -> Eval ctx (Record xs)
forall x (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value ctx -> EvaluationErrorType ctx
forall ctx. Text -> Value ctx -> EvaluationErrorType ctx
Evaluate.TypeMismatch Text
"object" Value ctx
other)

class FromJSONObject a where
  parseJSONObject :: Aeson.Object -> Aeson.Parser a
  
class ToJSONObject a where
  toJSONObject :: a -> Aeson.Object

class ToObject ctx a where
  toObject :: a -> HashMap Text (Value ctx)
  fromObject :: HashMap Text (Value ctx) -> Eval ctx a

data Nil = Nil

instance FromJSONObject Nil where
  parseJSONObject :: Object -> Parser Nil
parseJSONObject Object
_ = Nil -> Parser Nil
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nil
Nil
  
instance ToJSONObject Nil where 
  toJSONObject :: Nil -> Object
toJSONObject Nil
_ = Object
forall k v. HashMap k v
HashMap.empty

instance ToObject ctx Nil where
  toObject :: Nil -> HashMap Text (Value ctx)
toObject Nil
_ = HashMap Text (Value ctx)
forall k v. HashMap k v
HashMap.empty
  fromObject :: HashMap Text (Value ctx) -> Eval ctx Nil
fromObject HashMap Text (Value ctx)
_ = Nil -> Eval ctx Nil
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nil
Nil

data Cons (k :: Symbol) x xs = Cons x xs
  
instance forall k x xs. (KnownSymbol k, Aeson.FromJSON x, FromJSONObject xs) => FromJSONObject (Cons k x xs) where
  parseJSONObject :: Object -> Parser (Cons k x xs)
parseJSONObject Object
o =
    let k :: String
k = Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy k
forall k (t :: k). Proxy t
Proxy :: Proxy k)
     in x -> xs -> Cons k x xs
forall (k :: Symbol) x xs. x -> xs -> Cons k x xs
Cons (x -> xs -> Cons k x xs) -> Parser x -> Parser (xs -> Cons k x xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser x
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: (String -> Text
Text.pack String
k) Parser (xs -> Cons k x xs) -> Parser xs -> Parser (Cons k x xs)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser xs
forall a. FromJSONObject a => Object -> Parser a
parseJSONObject Object
o
  
instance forall k x xs. (KnownSymbol k, Aeson.ToJSON x, ToJSONObject xs) => ToJSONObject (Cons k x xs) where
  toJSONObject :: Cons k x xs -> Object
toJSONObject (Cons x
x xs
xs) =
    let k :: String
k = Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy k
forall k (t :: k). Proxy t
Proxy :: Proxy k)
     in Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert (String -> Text
Text.pack String
k) (x -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON x
x) (xs -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject xs
xs)

instance forall ctx k x xs. (KnownSymbol k, ToValue ctx x, ToObject ctx xs) => ToObject ctx (Cons k x xs) where
  toObject :: Cons k x xs -> HashMap Text (Value ctx)
toObject (Cons x
x xs
xs) = do
    let k :: String
k = Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy k
forall k (t :: k). Proxy t
Proxy :: Proxy k)
    Text
-> Value ctx
-> HashMap Text (Value ctx)
-> HashMap Text (Value ctx)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert (String -> Text
Text.pack String
k) (x -> Value ctx
forall ctx a. ToValue ctx a => a -> Value ctx
toValue x
x) (xs -> HashMap Text (Value ctx)
forall ctx a. ToObject ctx a => a -> HashMap Text (Value ctx)
toObject xs
xs)
        
  fromObject :: HashMap Text (Value ctx) -> Eval ctx (Cons k x xs)
fromObject HashMap Text (Value ctx)
m = do
    let k :: String
k = Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy k
forall k (t :: k). Proxy t
Proxy :: Proxy k)
    case Text -> HashMap Text (Value ctx) -> Maybe (Value ctx)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup (String -> Text
Text.pack String
k) HashMap Text (Value ctx)
m of
      Maybe (Value ctx)
Nothing -> 
        EvaluationErrorType ctx -> Eval ctx (Cons k x xs)
forall x (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value ctx -> EvaluationErrorType ctx
forall ctx. Text -> Value ctx -> EvaluationErrorType ctx
Evaluate.FieldNotFound (String -> Text
Text.pack String
k) (HashMap Text (Value ctx) -> Value ctx
forall ctx. HashMap Text (Value ctx) -> Value ctx
Evaluate.Object HashMap Text (Value ctx)
m))
      Just Value ctx
v -> 
        x -> xs -> Cons k x xs
forall (k :: Symbol) x xs. x -> xs -> Cons k x xs
Cons (x -> xs -> Cons k x xs)
-> Eval ctx x -> Eval ctx (xs -> Cons k x xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value ctx -> Eval ctx x
forall ctx a. ToValue ctx a => Value ctx -> Eval ctx a
fromValue Value ctx
v Eval ctx (xs -> Cons k x xs)
-> Eval ctx xs -> Eval ctx (Cons k x xs)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text (Value ctx) -> Eval ctx xs
forall ctx a.
ToObject ctx a =>
HashMap Text (Value ctx) -> Eval ctx a
fromObject HashMap Text (Value ctx)
m

-- | A representation of nullable values for use in derived serializers.
--
-- See 'reify' and 'stdlib'.
newtype Nullable a = Nullable (Maybe a)
  deriving (Value -> Parser [Nullable a]
Value -> Parser (Nullable a)
(Value -> Parser (Nullable a))
-> (Value -> Parser [Nullable a]) -> FromJSON (Nullable a)
forall a. FromJSON a => Value -> Parser [Nullable a]
forall a. FromJSON a => Value -> Parser (Nullable a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Nullable a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [Nullable a]
parseJSON :: Value -> Parser (Nullable a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (Nullable a)
Aeson.FromJSON, [Nullable a] -> Encoding
[Nullable a] -> Value
Nullable a -> Encoding
Nullable a -> Value
(Nullable a -> Value)
-> (Nullable a -> Encoding)
-> ([Nullable a] -> Value)
-> ([Nullable a] -> Encoding)
-> ToJSON (Nullable a)
forall a. ToJSON a => [Nullable a] -> Encoding
forall a. ToJSON a => [Nullable a] -> Value
forall a. ToJSON a => Nullable a -> Encoding
forall a. ToJSON a => Nullable a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Nullable a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [Nullable a] -> Encoding
toJSONList :: [Nullable a] -> Value
$ctoJSONList :: forall a. ToJSON a => [Nullable a] -> Value
toEncoding :: Nullable a -> Encoding
$ctoEncoding :: forall a. ToJSON a => Nullable a -> Encoding
toJSON :: Nullable a -> Value
$ctoJSON :: forall a. ToJSON a => Nullable a -> Value
Aeson.ToJSON) via Maybe a

instance ToValue ctx a => ToValue ctx (Nullable a) where
  toValue :: Nullable a -> Value ctx
toValue (Nullable Maybe a
Nothing) = 
    ProperName 'ConstructorName -> [Value ctx] -> Value ctx
forall ctx. ProperName 'ConstructorName -> [Value ctx] -> Value ctx
Evaluate.Constructor (Text -> ProperName 'ConstructorName
forall (a :: ProperNameType). Text -> ProperName a
Names.ProperName Text
"Null") []
  toValue (Nullable (Just a
a)) = 
    ProperName 'ConstructorName -> [Value ctx] -> Value ctx
forall ctx. ProperName 'ConstructorName -> [Value ctx] -> Value ctx
Evaluate.Constructor (Text -> ProperName 'ConstructorName
forall (a :: ProperNameType). Text -> ProperName a
Names.ProperName Text
"NotNull") [a -> Value ctx
forall ctx a. ToValue ctx a => a -> Value ctx
toValue a
a]
  
  fromValue :: Value ctx -> Eval ctx (Nullable a)
fromValue (Evaluate.Constructor (Names.ProperName Text
"Null") []) =
    Nullable a -> Eval ctx (Nullable a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Nullable a
forall a. Maybe a -> Nullable a
Nullable Maybe a
forall a. Maybe a
Nothing)
  fromValue (Evaluate.Constructor (Names.ProperName Text
"NotNull") [Value ctx
val]) =
    Maybe a -> Nullable a
forall a. Maybe a -> Nullable a
Nullable (Maybe a -> Nullable a) -> (a -> Maybe a) -> a -> Nullable a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just (a -> Nullable a) -> Eval ctx a -> Eval ctx (Nullable a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value ctx -> Eval ctx a
forall ctx a. ToValue ctx a => Value ctx -> Eval ctx a
fromValue Value ctx
val
  fromValue Value ctx
other =
    EvaluationErrorType ctx -> Eval ctx (Nullable a)
forall x (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value ctx -> EvaluationErrorType ctx
forall ctx. Text -> Value ctx -> EvaluationErrorType ctx
Evaluate.TypeMismatch Text
"Nullable" Value ctx
other)
    
-- | A representation of arbitrary JSON values for use in derived serializers.
--
-- This type is reified to stand in for any polymorphic type variables in a 
-- PureScript type, since we cannot know the structure of values of those types
-- ahead of time.
--
-- See 'reify' and 'stdlib'.
newtype UnknownJSON = UnknownJSON { UnknownJSON -> Value
getUnknownJSON :: Aeson.Value }
  deriving ([UnknownJSON] -> Encoding
[UnknownJSON] -> Value
UnknownJSON -> Encoding
UnknownJSON -> Value
(UnknownJSON -> Value)
-> (UnknownJSON -> Encoding)
-> ([UnknownJSON] -> Value)
-> ([UnknownJSON] -> Encoding)
-> ToJSON UnknownJSON
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UnknownJSON] -> Encoding
$ctoEncodingList :: [UnknownJSON] -> Encoding
toJSONList :: [UnknownJSON] -> Value
$ctoJSONList :: [UnknownJSON] -> Value
toEncoding :: UnknownJSON -> Encoding
$ctoEncoding :: UnknownJSON -> Encoding
toJSON :: UnknownJSON -> Value
$ctoJSON :: UnknownJSON -> Value
Aeson.ToJSON, Value -> Parser [UnknownJSON]
Value -> Parser UnknownJSON
(Value -> Parser UnknownJSON)
-> (Value -> Parser [UnknownJSON]) -> FromJSON UnknownJSON
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [UnknownJSON]
$cparseJSONList :: Value -> Parser [UnknownJSON]
parseJSON :: Value -> Parser UnknownJSON
$cparseJSON :: Value -> Parser UnknownJSON
Aeson.FromJSON) via Aeson.Value
  
instance ToValue ctx UnknownJSON where
  toValue :: UnknownJSON -> Value ctx
toValue = ForeignType Value -> Value ctx
forall ctx a. ToValue ctx a => a -> Value ctx
toValue (ForeignType Value -> Value ctx)
-> (UnknownJSON -> ForeignType Value) -> UnknownJSON -> Value ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ForeignType Value
forall a. a -> ForeignType a
Evaluate.ForeignType (Value -> ForeignType Value)
-> (UnknownJSON -> Value) -> UnknownJSON -> ForeignType Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnknownJSON -> Value
getUnknownJSON
  fromValue :: Value ctx -> Eval ctx UnknownJSON
fromValue = (ForeignType Value -> UnknownJSON)
-> Eval ctx (ForeignType Value) -> Eval ctx UnknownJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> UnknownJSON
UnknownJSON (Value -> UnknownJSON)
-> (ForeignType Value -> Value) -> ForeignType Value -> UnknownJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignType Value -> Value
forall a. ForeignType a -> a
Evaluate.getForeignType) (Eval ctx (ForeignType Value) -> Eval ctx UnknownJSON)
-> (Value ctx -> Eval ctx (ForeignType Value))
-> Value ctx
-> Eval ctx UnknownJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value ctx -> Eval ctx (ForeignType Value)
forall ctx a. ToValue ctx a => Value ctx -> Eval ctx a
fromValue
  
-- | This action makes a module named @JSON@ available to your PureScript code.
--
-- It defines the PureScript counterpart of the 'Nullable' type, which is used
-- to serialize nullable types when deriving serializers using 'reify'.
--
-- Any PureScript code which needs to support type-directed serialization for
-- values which may involve @null@ should import this module.
stdlib :: Interpret ctx (Module Ann)
stdlib :: Interpret ctx (Module Ann)
stdlib = Text -> Interpret ctx (Module Ann)
forall ctx. Text -> Interpret ctx (Module Ann)
build (Text -> Interpret ctx (Module Ann))
-> ([Text] -> Text) -> [Text] -> Interpret ctx (Module Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines ([Text] -> Interpret ctx (Module Ann))
-> [Text] -> Interpret ctx (Module Ann)
forall a b. (a -> b) -> a -> b
$
  [ Text
"module JSON where"
  , Text
""
  , Text
"data Nullable a = Null | NotNull a"
  ]