{-# LANGUAGE BlockArguments        #-}
{-# 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 is temporary and will be replaced or removed in a release shortly.
module Dovetail.JSON 
  ( tryReifySerializableType 
  , stdlib
  , Nullable(..)
  , UnknownJSON(..)
  ) where

import Control.Monad.Fix (MonadFix)  
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

tryReifySerializableType 
  :: forall m r
   . MonadFix m
  => P.SourceType 
  -> ( forall a
     . ( Aeson.FromJSON a
       , Aeson.ToJSON a
       , Evaluate.ToValue m a
       )
     => Proxy a
     -> EvalT m r
     )
  -> EvalT m r 
tryReifySerializableType :: SourceType
-> (forall a.
    (FromJSON a, ToJSON a, ToValue m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
tryReifySerializableType (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Int"))) forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f =
  Proxy Integer -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy Integer
forall k (t :: k). Proxy t
Proxy :: Proxy Integer)
tryReifySerializableType (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Number"))) forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f =
  Proxy Double -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy Double
forall k (t :: k). Proxy t
Proxy :: Proxy Double)
tryReifySerializableType (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"String"))) forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f =
  Proxy Text -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy Text
forall k (t :: k). Proxy t
Proxy :: Proxy Text)
tryReifySerializableType (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Char"))) forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f =
  Proxy Char -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy Char
forall k (t :: k). Proxy t
Proxy :: Proxy Char)
tryReifySerializableType (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Boolean"))) forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f =
  Proxy Bool -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy Bool
forall k (t :: k). Proxy t
Proxy :: Proxy Bool)
tryReifySerializableType (P.TypeApp SourceAnn
_ (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Record"))) SourceType
ty) forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m 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
  
      go :: P.SourceType -> EvalT m r
      go :: SourceType -> EvalT m r
go (P.KindApp SourceAnn
_ P.REmpty{} SourceType
_) =
        [RowListItem SourceAnn]
-> (forall a.
    (FromJSONObject a, ToJSONObject a, ToObject m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
forall (m :: * -> *) r.
MonadFix m =>
[RowListItem SourceAnn]
-> (forall a.
    (FromJSONObject a, ToJSONObject a, ToObject m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
tryReifyRecordType [RowListItem SourceAnn]
knownFields (\(Proxy a
Proxy :: Proxy xs) -> Proxy (Record a) -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy (Record a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Record xs)))
      go (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"JSON")) (P.ProperName Text
"JSON"))) = 
        [RowListItem SourceAnn]
-> (forall a.
    (FromJSONObject a, ToJSONObject a, ToObject m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
forall (m :: * -> *) r.
MonadFix m =>
[RowListItem SourceAnn]
-> (forall a.
    (FromJSONObject a, ToJSONObject a, ToObject m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
tryReifyRecordType [RowListItem SourceAnn]
knownFields (\(Proxy a
Proxy :: Proxy xs) -> Proxy (OpenRecord a) -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy (OpenRecord a)
forall k (t :: k). Proxy t
Proxy :: Proxy (OpenRecord xs)))
      go SourceType
_ =
        EvaluationErrorType m -> EvalT m r
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> EvaluationErrorType m
forall (m :: * -> *). Text -> EvaluationErrorType m
Evaluate.OtherError Text
"record type is not serializable")
  SourceType -> EvalT m r
go SourceType
unknownFields
tryReifySerializableType (P.TypeApp SourceAnn
_ (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"Prim")) (P.ProperName Text
"Array"))) SourceType
ty) forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f =
  SourceType
-> (forall a.
    (FromJSON a, ToJSON a, ToValue m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
forall (m :: * -> *) r.
MonadFix m =>
SourceType
-> (forall a.
    (FromJSON a, ToJSON a, ToValue m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
tryReifySerializableType SourceType
ty (\(Proxy a
Proxy :: Proxy a) -> Proxy (Vector a) -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy (Vector a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Vector a)))
tryReifySerializableType (P.TypeApp SourceAnn
_ (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"JSON")) (P.ProperName Text
"Nullable"))) SourceType
ty) forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f =
  SourceType
-> (forall a.
    (FromJSON a, ToJSON a, ToValue m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
forall (m :: * -> *) r.
MonadFix m =>
SourceType
-> (forall a.
    (FromJSON a, ToJSON a, ToValue m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
tryReifySerializableType SourceType
ty (\(Proxy a
Proxy :: Proxy a) -> Proxy (Nullable a) -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy (Nullable a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Nullable a)))
tryReifySerializableType (P.TypeConstructor SourceAnn
_ (P.Qualified (Just (P.ModuleName Text
"JSON")) (P.ProperName Text
"JSON"))) forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f =
  Proxy UnknownJSON -> EvalT m r
forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
f (Proxy UnknownJSON
forall k (t :: k). Proxy t
Proxy :: Proxy UnknownJSON)  
tryReifySerializableType SourceType
_  forall a.
(FromJSON a, ToJSON a, ToValue m a) =>
Proxy a -> EvalT m r
_ =
  EvaluationErrorType m -> EvalT m r
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> EvaluationErrorType m
forall (m :: * -> *). Text -> EvaluationErrorType m
Evaluate.OtherError Text
"type is not serializable")

tryReifyRecordType
  :: forall m r
   . MonadFix m
  => [P.RowListItem P.SourceAnn]
  -> ( forall a
     . ( FromJSONObject a
       , ToJSONObject a
       , ToObject m a
       )
     => Proxy a
     -> EvalT m r
     )
  -> EvalT m r 
tryReifyRecordType :: [RowListItem SourceAnn]
-> (forall a.
    (FromJSONObject a, ToJSONObject a, ToObject m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
tryReifyRecordType [] forall a.
(FromJSONObject a, ToJSONObject a, ToObject m a) =>
Proxy a -> EvalT m r
f = 
  Proxy Nil -> EvalT m r
forall a.
(FromJSONObject a, ToJSONObject a, ToObject m a) =>
Proxy a -> EvalT m r
f (Proxy Nil
forall k (t :: k). Proxy t
Proxy :: Proxy Nil)
tryReifyRecordType (P.RowListItem SourceAnn
_ (Label.Label PSString
k) SourceType
x : [RowListItem SourceAnn]
xs) forall a.
(FromJSONObject a, ToJSONObject a, ToObject m a) =>
Proxy a -> EvalT m r
f = do
  Text
t <- PSString -> EvalT m Text
forall (m :: * -> *). MonadFix m => PSString -> EvalT m Text
Evaluate.evalPSString PSString
k
  String
-> (forall (n :: Symbol). KnownSymbol n => Proxy n -> EvalT m r)
-> EvalT m 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.
    (FromJSON a, ToJSON a, ToValue m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
forall (m :: * -> *) r.
MonadFix m =>
SourceType
-> (forall a.
    (FromJSON a, ToJSON a, ToValue m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
tryReifySerializableType SourceType
x \(Proxy a
Proxy :: Proxy x) ->
      [RowListItem SourceAnn]
-> (forall a.
    (FromJSONObject a, ToJSONObject a, ToObject m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
forall (m :: * -> *) r.
MonadFix m =>
[RowListItem SourceAnn]
-> (forall a.
    (FromJSONObject a, ToJSONObject a, ToObject m a) =>
    Proxy a -> EvalT m r)
-> EvalT m r
tryReifyRecordType [RowListItem SourceAnn]
xs \(Proxy a
Proxy :: Proxy xs) ->
        Proxy (Cons n a a) -> EvalT m r
forall a.
(FromJSONObject a, ToJSONObject a, ToObject m a) =>
Proxy a -> EvalT m 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 (MonadFix m, ToObject m xs) => ToValue m (OpenRecord xs) where
  toValue :: OpenRecord xs -> Value m
toValue (OpenRecord xs
xs HashMap Text UnknownJSON
o) = HashMap Text (Value m) -> Value m
forall (m :: * -> *). HashMap Text (Value m) -> Value m
Evaluate.Object (xs -> HashMap Text (Value m)
forall (m :: * -> *) a. ToObject m a => a -> HashMap Text (Value m)
toObject xs
xs HashMap Text (Value m)
-> HashMap Text (Value m) -> HashMap Text (Value m)
forall a. Semigroup a => a -> a -> a
<> (UnknownJSON -> Value m)
-> HashMap Text UnknownJSON -> HashMap Text (Value m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnknownJSON -> Value m
forall (m :: * -> *) a. ToValue m a => a -> Value m
toValue HashMap Text UnknownJSON
o)
  
  fromValue :: Value m -> EvalT m (OpenRecord xs)
fromValue (Evaluate.Object HashMap Text (Value m)
o) = 
    let isUnknownJSON :: Value m -> Bool
isUnknownJSON (Evaluate.Foreign Dynamic
dyn)
          | Just{} <- Dynamic -> Maybe UnknownJSON
forall a. Typeable a => Dynamic -> Maybe a
Dynamic.fromDynamic @UnknownJSON Dynamic
dyn = Bool
True
        isUnknownJSON Value m
_ = Bool
False
     in xs -> HashMap Text UnknownJSON -> OpenRecord xs
forall xs. xs -> HashMap Text UnknownJSON -> OpenRecord xs
OpenRecord (xs -> HashMap Text UnknownJSON -> OpenRecord xs)
-> EvalT m xs
-> EvalT m (HashMap Text UnknownJSON -> OpenRecord xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (Value m) -> EvalT m xs
forall (m :: * -> *) a.
ToObject m a =>
HashMap Text (Value m) -> EvalT m a
fromObject HashMap Text (Value m)
o EvalT m (HashMap Text UnknownJSON -> OpenRecord xs)
-> EvalT m (HashMap Text UnknownJSON) -> EvalT m (OpenRecord xs)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value m -> EvalT m UnknownJSON)
-> HashMap Text (Value m) -> EvalT m (HashMap Text UnknownJSON)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value m -> EvalT m UnknownJSON
forall (m :: * -> *) a. ToValue m a => Value m -> EvalT m a
fromValue ((Value m -> Bool)
-> HashMap Text (Value m) -> HashMap Text (Value m)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter Value m -> Bool
forall (m :: * -> *). Value m -> Bool
isUnknownJSON HashMap Text (Value m)
o)
  fromValue Value m
other = 
    EvaluationErrorType m -> EvalT m (OpenRecord xs)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
Evaluate.TypeMismatch Text
"object" Value m
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 (MonadFix m, ToObject m xs) => ToValue m (Record xs) where
  toValue :: Record xs -> Value m
toValue = HashMap Text (Value m) -> Value m
forall (m :: * -> *). HashMap Text (Value m) -> Value m
Evaluate.Object (HashMap Text (Value m) -> Value m)
-> (Record xs -> HashMap Text (Value m)) -> Record xs -> Value m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. xs -> HashMap Text (Value m)
forall (m :: * -> *) a. ToObject m a => a -> HashMap Text (Value m)
toObject (xs -> HashMap Text (Value m))
-> (Record xs -> xs) -> Record xs -> HashMap Text (Value m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record xs -> xs
forall xs. Record xs -> xs
getRecord
  
  fromValue :: Value m -> EvalT m (Record xs)
fromValue (Evaluate.Object HashMap Text (Value m)
o) = 
    xs -> Record xs
forall xs. xs -> Record xs
Record (xs -> Record xs) -> EvalT m xs -> EvalT m (Record xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (Value m) -> EvalT m xs
forall (m :: * -> *) a.
ToObject m a =>
HashMap Text (Value m) -> EvalT m a
fromObject HashMap Text (Value m)
o 
  fromValue Value m
other = 
    EvaluationErrorType m -> EvalT m (Record xs)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
Evaluate.TypeMismatch Text
"object" Value m
other)

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

class ToObject m a where
  toObject :: a -> HashMap Text (Value m)
  fromObject :: HashMap Text (Value m) -> EvalT m 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 Monad m => ToObject m Nil where
  toObject :: Nil -> HashMap Text (Value m)
toObject Nil
_ = HashMap Text (Value m)
forall k v. HashMap k v
HashMap.empty
  fromObject :: HashMap Text (Value m) -> EvalT m Nil
fromObject HashMap Text (Value m)
_ = Nil -> EvalT m 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 m k x xs. (KnownSymbol k, ToValue m x, ToObject m xs) => ToObject m (Cons k x xs) where
  toObject :: Cons k x xs -> HashMap Text (Value m)
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 m -> HashMap Text (Value m) -> HashMap Text (Value m)
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 m
forall (m :: * -> *) a. ToValue m a => a -> Value m
toValue x
x) (xs -> HashMap Text (Value m)
forall (m :: * -> *) a. ToObject m a => a -> HashMap Text (Value m)
toObject xs
xs)
        
  fromObject :: HashMap Text (Value m) -> EvalT m (Cons k x xs)
fromObject HashMap Text (Value m)
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 m) -> Maybe (Value m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup (String -> Text
Text.pack String
k) HashMap Text (Value m)
m of
      Maybe (Value m)
Nothing -> 
        EvaluationErrorType m -> EvalT m (Cons k x xs)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
Evaluate.FieldNotFound (String -> Text
Text.pack String
k) (HashMap Text (Value m) -> Value m
forall (m :: * -> *). HashMap Text (Value m) -> Value m
Evaluate.Object HashMap Text (Value m)
m))
      Just Value m
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)
-> EvalT m x -> EvalT m (xs -> Cons k x xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value m -> EvalT m x
forall (m :: * -> *) a. ToValue m a => Value m -> EvalT m a
fromValue Value m
v EvalT m (xs -> Cons k x xs) -> EvalT m xs -> EvalT m (Cons k x xs)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text (Value m) -> EvalT m xs
forall (m :: * -> *) a.
ToObject m a =>
HashMap Text (Value m) -> EvalT m a
fromObject HashMap Text (Value m)
m

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 m a => ToValue m (Nullable a) where
  toValue :: Nullable a -> Value m
toValue (Nullable Maybe a
Nothing) = 
    ProperName 'ConstructorName -> [Value m] -> Value m
forall (m :: * -> *).
ProperName 'ConstructorName -> [Value m] -> Value m
Evaluate.Constructor (Text -> ProperName 'ConstructorName
forall (a :: ProperNameType). Text -> ProperName a
Names.ProperName Text
"Null") []
  toValue (Nullable (Just a
a)) = 
    ProperName 'ConstructorName -> [Value m] -> Value m
forall (m :: * -> *).
ProperName 'ConstructorName -> [Value m] -> Value m
Evaluate.Constructor (Text -> ProperName 'ConstructorName
forall (a :: ProperNameType). Text -> ProperName a
Names.ProperName Text
"NotNull") [a -> Value m
forall (m :: * -> *) a. ToValue m a => a -> Value m
toValue a
a]
  
  fromValue :: Value m -> EvalT m (Nullable a)
fromValue (Evaluate.Constructor (Names.ProperName Text
"Null") []) =
    Nullable a -> EvalT m (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 m
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) -> EvalT m a -> EvalT m (Nullable a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value m -> EvalT m a
forall (m :: * -> *) a. ToValue m a => Value m -> EvalT m a
fromValue Value m
val
  fromValue Value m
other =
    EvaluationErrorType m -> EvalT m (Nullable a)
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
Evaluate.TypeMismatch Text
"Nullable" Value m
other)
    
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 MonadFix m => ToValue m UnknownJSON where
  toValue :: UnknownJSON -> Value m
toValue = Dynamic -> Value m
forall (m :: * -> *). Dynamic -> Value m
Foreign (Dynamic -> Value m)
-> (UnknownJSON -> Dynamic) -> UnknownJSON -> Value m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typeable UnknownJSON => UnknownJSON -> Dynamic
forall a. Typeable a => a -> Dynamic
Dynamic.toDyn @UnknownJSON
  fromValue :: Value m -> EvalT m UnknownJSON
fromValue (Evaluate.Foreign Dynamic
dyn) =
    case Dynamic -> Maybe UnknownJSON
forall a. Typeable a => Dynamic -> Maybe a
Dynamic.fromDynamic @UnknownJSON Dynamic
dyn of
      Maybe UnknownJSON
Nothing ->
        EvaluationErrorType m -> EvalT m UnknownJSON
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
Evaluate.TypeMismatch Text
"UnknownJSON" (Dynamic -> Value m
forall (m :: * -> *). Dynamic -> Value m
Evaluate.Foreign Dynamic
dyn))
      Just UnknownJSON
json ->
        UnknownJSON -> EvalT m UnknownJSON
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnknownJSON
json
  fromValue Value m
other = 
    EvaluationErrorType m -> EvalT m UnknownJSON
forall (x :: * -> *) (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
Evaluate.throwErrorWithContext (Text -> Value m -> EvaluationErrorType m
forall (m :: * -> *). Text -> Value m -> EvaluationErrorType m
Evaluate.TypeMismatch Text
"UnknownJSON" Value m
other)
  
stdlib :: MonadFix m => InterpretT m (Module Ann)
stdlib :: InterpretT m (Module Ann)
stdlib = Text -> InterpretT m (Module Ann)
forall (m :: * -> *).
MonadFix m =>
Text -> InterpretT m (Module Ann)
build (Text -> InterpretT m (Module Ann))
-> ([Text] -> Text) -> [Text] -> InterpretT m (Module Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines ([Text] -> InterpretT m (Module Ann))
-> [Text] -> InterpretT m (Module Ann)
forall a b. (a -> b) -> a -> b
$
  [ Text
"module JSON where"
  , Text
""
  , Text
"data Nullable a = Null | NotNull a"
  , Text
""
  , Text
"foreign import data JSON :: Type"
  ]