{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.AST.Value
  ( Value (..),
    ScalarValue (..),
    Object,
    replaceValue,
    decodeScientific,
    RawValue,
    ValidValue,
    RawObject,
    ValidObject,
    Variable (..),
    ResolvedValue,
    ResolvedObject,
    VariableContent (..),
    ObjectEntry (..),
    VariableDefinitions,
  )
where

-- MORPHEUS
import qualified Data.Aeson as A
  ( (.=),
    FromJSON (..),
    ToJSON (..),
    Value (..),
    object,
    pairs,
  )
import Data.Foldable (foldr')
import qualified Data.HashMap.Lazy as M
import Data.Morpheus.Error.NameCollision
  ( NameCollision (..),
  )
import Data.Morpheus.Ext.OrdMap
  ( OrdMap,
    unsafeFromList,
  )
import Data.Morpheus.Internal.Utils
  ( KeyOf (..),
    elems,
    mapTuple,
  )
import Data.Morpheus.Rendering.RenderGQL
  ( RenderGQL (..),
    fromText,
    render,
    renderInputSeq,
    space,
  )
import Data.Morpheus.Types.Internal.AST.Base
  ( FieldName,
    FieldName (..),
    Msg (..),
    Position,
    Ref (..),
    TypeName (..),
    ValidationError (..),
    msgValidation,
  )
import Data.Morpheus.Types.Internal.AST.Stage
  ( CONST,
    CONST_OR_VALID,
    RAW,
    Stage,
    VALID,
  )
import Data.Morpheus.Types.Internal.AST.Type (TypeRef (..))
import Data.Scientific
  ( Scientific,
    floatingOrInteger,
  )
import qualified Data.Vector as V
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift (..))
import Relude

-- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'.
-- for performance reason type 'Text' represents GraphQl 'String' value
data ScalarValue
  = Int Int
  | Float Double
  | String Text
  | Boolean Bool
  | Value A.Value
  deriving (Int -> ScalarValue -> ShowS
[ScalarValue] -> ShowS
ScalarValue -> String
(Int -> ScalarValue -> ShowS)
-> (ScalarValue -> String)
-> ([ScalarValue] -> ShowS)
-> Show ScalarValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScalarValue] -> ShowS
$cshowList :: [ScalarValue] -> ShowS
show :: ScalarValue -> String
$cshow :: ScalarValue -> String
showsPrec :: Int -> ScalarValue -> ShowS
$cshowsPrec :: Int -> ScalarValue -> ShowS
Show, ScalarValue -> ScalarValue -> Bool
(ScalarValue -> ScalarValue -> Bool)
-> (ScalarValue -> ScalarValue -> Bool) -> Eq ScalarValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScalarValue -> ScalarValue -> Bool
$c/= :: ScalarValue -> ScalarValue -> Bool
== :: ScalarValue -> ScalarValue -> Bool
$c== :: ScalarValue -> ScalarValue -> Bool
Eq, (forall x. ScalarValue -> Rep ScalarValue x)
-> (forall x. Rep ScalarValue x -> ScalarValue)
-> Generic ScalarValue
forall x. Rep ScalarValue x -> ScalarValue
forall x. ScalarValue -> Rep ScalarValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ScalarValue x -> ScalarValue
$cfrom :: forall x. ScalarValue -> Rep ScalarValue x
Generic, ScalarValue -> Q Exp
ScalarValue -> Q (TExp ScalarValue)
(ScalarValue -> Q Exp)
-> (ScalarValue -> Q (TExp ScalarValue)) -> Lift ScalarValue
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: ScalarValue -> Q (TExp ScalarValue)
$cliftTyped :: ScalarValue -> Q (TExp ScalarValue)
lift :: ScalarValue -> Q Exp
$clift :: ScalarValue -> Q Exp
Lift)

instance RenderGQL ScalarValue where
  renderGQL :: ScalarValue -> Rendering
renderGQL (Int Int
x) = Int -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL Int
x
  renderGQL (Float Double
x) = Double -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL Double
x
  renderGQL (String Text
x) = Text -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL Text
x
  renderGQL (Boolean Bool
x) = Bool -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL Bool
x
  renderGQL (Value Value
x) = Value -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL Value
x

instance A.ToJSON ScalarValue where
  toJSON :: ScalarValue -> Value
toJSON (Float Double
x) = Double -> Value
forall a. ToJSON a => a -> Value
A.toJSON Double
x
  toJSON (Int Int
x) = Int -> Value
forall a. ToJSON a => a -> Value
A.toJSON Int
x
  toJSON (Boolean Bool
x) = Bool -> Value
forall a. ToJSON a => a -> Value
A.toJSON Bool
x
  toJSON (String Text
x) = Text -> Value
forall a. ToJSON a => a -> Value
A.toJSON Text
x
  toJSON (Value Value
x) = Value -> Value
forall a. ToJSON a => a -> Value
A.toJSON Value
x

instance A.FromJSON ScalarValue where
  parseJSON :: Value -> Parser ScalarValue
parseJSON (A.Bool Bool
v) = ScalarValue -> Parser ScalarValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarValue -> Parser ScalarValue)
-> ScalarValue -> Parser ScalarValue
forall a b. (a -> b) -> a -> b
$ Bool -> ScalarValue
Boolean Bool
v
  parseJSON (A.Number Scientific
v) = ScalarValue -> Parser ScalarValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarValue -> Parser ScalarValue)
-> ScalarValue -> Parser ScalarValue
forall a b. (a -> b) -> a -> b
$ Scientific -> ScalarValue
decodeScientific Scientific
v
  parseJSON (A.String Text
v) = ScalarValue -> Parser ScalarValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarValue -> Parser ScalarValue)
-> ScalarValue -> Parser ScalarValue
forall a b. (a -> b) -> a -> b
$ Text -> ScalarValue
String Text
v
  parseJSON Value
notScalar = String -> Parser ScalarValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ScalarValue) -> String -> Parser ScalarValue
forall a b. (a -> b) -> a -> b
$ String
"Expected Scalar got :" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall b a. (Show a, IsString b) => a -> b
show Value
notScalar

data VariableContent (stage :: Stage) where
  DefaultValue :: Maybe ResolvedValue -> VariableContent CONST
  ValidVariableValue :: {VariableContent VALID -> ValidValue
validVarContent :: ValidValue} -> VariableContent VALID

instance Lift (VariableContent a) where
  lift :: VariableContent a -> Q Exp
lift (DefaultValue Maybe ResolvedValue
x) = [|DefaultValue x|]
  lift (ValidVariableValue ValidValue
x) = [|ValidVariableValue x|]

#if MIN_VERSION_template_haskell(2,16,0)
  liftTyped :: VariableContent a -> Q (TExp (VariableContent a))
liftTyped (DefaultValue Maybe ResolvedValue
x) = [||DefaultValue x||]
  liftTyped (ValidVariableValue ValidValue
x) = [||ValidVariableValue x||]
#endif
deriving instance Show (VariableContent a)

deriving instance Eq (VariableContent a)

data Variable (stage :: Stage) = Variable
  { Variable stage -> Position
variablePosition :: Position,
    Variable stage -> FieldName
variableName :: FieldName,
    Variable stage -> TypeRef
variableType :: TypeRef,
    Variable stage -> VariableContent (CONST_OR_VALID stage)
variableValue :: VariableContent (CONST_OR_VALID stage)
  }
  deriving (Int -> Variable stage -> ShowS
[Variable stage] -> ShowS
Variable stage -> String
(Int -> Variable stage -> ShowS)
-> (Variable stage -> String)
-> ([Variable stage] -> ShowS)
-> Show (Variable stage)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (stage :: Stage). Int -> Variable stage -> ShowS
forall (stage :: Stage). [Variable stage] -> ShowS
forall (stage :: Stage). Variable stage -> String
showList :: [Variable stage] -> ShowS
$cshowList :: forall (stage :: Stage). [Variable stage] -> ShowS
show :: Variable stage -> String
$cshow :: forall (stage :: Stage). Variable stage -> String
showsPrec :: Int -> Variable stage -> ShowS
$cshowsPrec :: forall (stage :: Stage). Int -> Variable stage -> ShowS
Show, Variable stage -> Variable stage -> Bool
(Variable stage -> Variable stage -> Bool)
-> (Variable stage -> Variable stage -> Bool)
-> Eq (Variable stage)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (stage :: Stage). Variable stage -> Variable stage -> Bool
/= :: Variable stage -> Variable stage -> Bool
$c/= :: forall (stage :: Stage). Variable stage -> Variable stage -> Bool
== :: Variable stage -> Variable stage -> Bool
$c== :: forall (stage :: Stage). Variable stage -> Variable stage -> Bool
Eq, Variable stage -> Q Exp
Variable stage -> Q (TExp (Variable stage))
(Variable stage -> Q Exp)
-> (Variable stage -> Q (TExp (Variable stage)))
-> Lift (Variable stage)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (stage :: Stage). Variable stage -> Q Exp
forall (stage :: Stage).
Variable stage -> Q (TExp (Variable stage))
liftTyped :: Variable stage -> Q (TExp (Variable stage))
$cliftTyped :: forall (stage :: Stage).
Variable stage -> Q (TExp (Variable stage))
lift :: Variable stage -> Q Exp
$clift :: forall (stage :: Stage). Variable stage -> Q Exp
Lift)

instance KeyOf FieldName (Variable s) where
  keyOf :: Variable s -> FieldName
keyOf = Variable s -> FieldName
forall (s :: Stage). Variable s -> FieldName
variableName

instance NameCollision (Variable s) where
  nameCollision :: Variable s -> ValidationError
nameCollision Variable {FieldName
variableName :: FieldName
variableName :: forall (s :: Stage). Variable s -> FieldName
variableName, Position
variablePosition :: Position
variablePosition :: forall (stage :: Stage). Variable stage -> Position
variablePosition} =
    ValidationError :: Message -> [Position] -> ValidationError
ValidationError
      { validationMessage :: Message
validationMessage = Message
"There can Be only One Variable Named " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
variableName,
        validationLocations :: [Position]
validationLocations = [Position
variablePosition]
      }

type VariableDefinitions s = OrdMap FieldName (Variable s)

data Value (stage :: Stage) where
  ResolvedVariable :: Ref FieldName -> Variable VALID -> Value CONST
  VariableValue :: Ref FieldName -> Value RAW
  Object :: Object stage -> Value stage
  List :: [Value stage] -> Value stage
  Enum :: TypeName -> Value stage
  Scalar :: ScalarValue -> Value stage
  Null :: Value stage

deriving instance Show (Value a)

deriving instance Eq (Value s)

data ObjectEntry (s :: Stage) = ObjectEntry
  { ObjectEntry s -> FieldName
entryName :: FieldName,
    ObjectEntry s -> Value s
entryValue :: Value s
  }
  deriving (ObjectEntry s -> ObjectEntry s -> Bool
(ObjectEntry s -> ObjectEntry s -> Bool)
-> (ObjectEntry s -> ObjectEntry s -> Bool) -> Eq (ObjectEntry s)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: Stage). ObjectEntry s -> ObjectEntry s -> Bool
/= :: ObjectEntry s -> ObjectEntry s -> Bool
$c/= :: forall (s :: Stage). ObjectEntry s -> ObjectEntry s -> Bool
== :: ObjectEntry s -> ObjectEntry s -> Bool
$c== :: forall (s :: Stage). ObjectEntry s -> ObjectEntry s -> Bool
Eq, Int -> ObjectEntry s -> ShowS
[ObjectEntry s] -> ShowS
ObjectEntry s -> String
(Int -> ObjectEntry s -> ShowS)
-> (ObjectEntry s -> String)
-> ([ObjectEntry s] -> ShowS)
-> Show (ObjectEntry s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Stage). Int -> ObjectEntry s -> ShowS
forall (s :: Stage). [ObjectEntry s] -> ShowS
forall (s :: Stage). ObjectEntry s -> String
showList :: [ObjectEntry s] -> ShowS
$cshowList :: forall (s :: Stage). [ObjectEntry s] -> ShowS
show :: ObjectEntry s -> String
$cshow :: forall (s :: Stage). ObjectEntry s -> String
showsPrec :: Int -> ObjectEntry s -> ShowS
$cshowsPrec :: forall (s :: Stage). Int -> ObjectEntry s -> ShowS
Show)

instance RenderGQL (ObjectEntry a) where
  renderGQL :: ObjectEntry a -> Rendering
renderGQL (ObjectEntry (FieldName Text
name) Value a
value) = Text -> Rendering
fromText Text
name Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
": " Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Value a -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL Value a
value

instance NameCollision (ObjectEntry s) where
  nameCollision :: ObjectEntry s -> ValidationError
nameCollision ObjectEntry {FieldName
entryName :: FieldName
entryName :: forall (s :: Stage). ObjectEntry s -> FieldName
entryName} =
    ValidationError
"There can Be only One field Named " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> FieldName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation FieldName
entryName :: ValidationError

instance KeyOf FieldName (ObjectEntry s) where
  keyOf :: ObjectEntry s -> FieldName
keyOf = ObjectEntry s -> FieldName
forall (s :: Stage). ObjectEntry s -> FieldName
entryName

type Object a = OrdMap FieldName (ObjectEntry a)

type ValidObject = Object VALID

type RawObject = Object RAW

type ResolvedObject = Object CONST

type RawValue = Value RAW

type ValidValue = Value VALID

type ResolvedValue = Value CONST

deriving instance Lift (Value a)

deriving instance Lift (ObjectEntry a)

instance RenderGQL (Value a) where
  renderGQL :: Value a -> Rendering
renderGQL (ResolvedVariable Ref {FieldName
refName :: forall name. Ref name -> name
refName :: FieldName
refName} Variable VALID
_) = Rendering
"$" Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> FieldName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL FieldName
refName
  renderGQL (VariableValue Ref {FieldName
refName :: FieldName
refName :: forall name. Ref name -> name
refName}) = Rendering
"$" Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> FieldName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL FieldName
refName Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
" "
  renderGQL Value a
Null = Rendering
"null"
  renderGQL (Enum TypeName
x) = TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL TypeName
x
  renderGQL (Scalar ScalarValue
x) = ScalarValue -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL ScalarValue
x
  renderGQL (Object Object a
xs) = Rendering
"{" Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
entries Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
"}"
    where
      entries :: Rendering
entries
        | [ObjectEntry a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Object a -> [ObjectEntry a]
forall a coll. Elems a coll => coll -> [a]
elems Object a
xs) = Rendering
""
        | Bool
otherwise = Rendering
space Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> [ObjectEntry a] -> Rendering
forall (t :: * -> *) a.
(Foldable t, RenderGQL a) =>
t a -> Rendering
renderInputSeq (Object a -> [ObjectEntry a]
forall a coll. Elems a coll => coll -> [a]
elems Object a
xs) Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
space
  renderGQL (List [Value a]
list) = Rendering
"[" Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> [Value a] -> Rendering
forall (t :: * -> *) a.
(Foldable t, RenderGQL a) =>
t a -> Rendering
renderInputSeq [Value a]
list Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
"]"

instance Msg (Value a) where
  msg :: Value a -> Message
msg = ByteString -> Message
forall a. Msg a => a -> Message
msg (ByteString -> Message)
-> (Value a -> ByteString) -> Value a -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value a -> ByteString
forall a. RenderGQL a => a -> ByteString
render

instance A.ToJSON (Value a) where
  toJSON :: Value a -> Value
toJSON (ResolvedVariable Ref FieldName
_ Variable {variableValue :: forall (stage :: Stage).
Variable stage -> VariableContent (CONST_OR_VALID stage)
variableValue = ValidVariableValue ValidValue
x}) =
    ValidValue -> Value
forall a. ToJSON a => a -> Value
A.toJSON ValidValue
x
  toJSON (VariableValue Ref {FieldName
refName :: FieldName
refName :: forall name. Ref name -> name
refName}) =
    Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text
"($ref:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldName -> Text
readName FieldName
refName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  toJSON Value a
Null = Value
A.Null
  toJSON (Enum (TypeName Text
x)) = Text -> Value
A.String Text
x
  toJSON (Scalar ScalarValue
x) = ScalarValue -> Value
forall a. ToJSON a => a -> Value
A.toJSON ScalarValue
x
  toJSON (List [Value a]
x) = [Value a] -> Value
forall a. ToJSON a => a -> Value
A.toJSON [Value a]
x
  toJSON (Object Object a
fields) = [Pair] -> Value
A.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (ObjectEntry a -> Pair) -> [ObjectEntry a] -> [Pair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ObjectEntry a -> Pair
forall kv (s :: Stage). KeyValue kv => ObjectEntry s -> kv
toEntry (Object a -> [ObjectEntry a]
forall a coll. Elems a coll => coll -> [a]
elems Object a
fields)
    where
      toEntry :: ObjectEntry s -> kv
toEntry (ObjectEntry (FieldName Text
name) Value s
value) = Text
name Text -> Value -> kv
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Value s -> Value
forall a. ToJSON a => a -> Value
A.toJSON Value s
value

  -------------------------------------------
  toEncoding :: Value a -> Encoding
toEncoding (ResolvedVariable Ref FieldName
_ Variable {variableValue :: forall (stage :: Stage).
Variable stage -> VariableContent (CONST_OR_VALID stage)
variableValue = ValidVariableValue ValidValue
x}) =
    ValidValue -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding ValidValue
x
  toEncoding (VariableValue Ref {FieldName
refName :: FieldName
refName :: forall name. Ref name -> name
refName}) =
    FieldName -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding (FieldName -> Encoding) -> FieldName -> Encoding
forall a b. (a -> b) -> a -> b
$ FieldName
"($ref:" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> FieldName
refName FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> FieldName
")"
  toEncoding Value a
Null = Value -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding Value
A.Null
  toEncoding (Enum TypeName
x) = TypeName -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding TypeName
x
  toEncoding (Scalar ScalarValue
x) = ScalarValue -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding ScalarValue
x
  toEncoding (List [Value a]
x) = [Value a] -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding [Value a]
x
  toEncoding (Object Object a
ordMap) = Series -> Encoding
A.pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ (ObjectEntry a -> Series) -> [ObjectEntry a] -> Series
forall p e. (Semigroup p, Monoid p) => (e -> p) -> [e] -> p
renderSeries ObjectEntry a -> Series
forall kv (s :: Stage). KeyValue kv => ObjectEntry s -> kv
encodeField (Object a -> [ObjectEntry a]
forall a coll. Elems a coll => coll -> [a]
elems Object a
ordMap)
    where
      encodeField :: ObjectEntry s -> kv
encodeField (ObjectEntry (FieldName Text
key) Value s
value) = Text
key Text -> Value s -> kv
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Value s
value

-- fixes GHC 8.2.2, which can't deduce (Semigroup p) from context (Monoid p)
renderSeries :: (Semigroup p, Monoid p) => (e -> p) -> [e] -> p
renderSeries :: (e -> p) -> [e] -> p
renderSeries e -> p
_ [] = p
forall a. Monoid a => a
mempty
renderSeries e -> p
f (e
x : [e]
xs) = (e -> p -> p) -> p -> [e] -> p
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (\e
e p
es -> p
es p -> p -> p
forall a. Semigroup a => a -> a -> a
<> e -> p
f e
e) (e -> p
f e
x) [e]
xs

decodeScientific :: Scientific -> ScalarValue
decodeScientific :: Scientific -> ScalarValue
decodeScientific Scientific
v = case Scientific -> Either Double Int
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
v of
  Left Double
float -> Double -> ScalarValue
Float Double
float
  Right Int
int -> Int -> ScalarValue
Int Int
int

replaceValue :: A.Value -> Value a
replaceValue :: Value -> Value a
replaceValue (A.Bool Bool
v) = Bool -> Value a
forall (s :: Stage). Bool -> Value s
mkBoolean Bool
v
replaceValue (A.Number Scientific
v) = ScalarValue -> Value a
forall (stage :: Stage). ScalarValue -> Value stage
Scalar (ScalarValue -> Value a) -> ScalarValue -> Value a
forall a b. (a -> b) -> a -> b
$ Scientific -> ScalarValue
decodeScientific Scientific
v
replaceValue (A.String Text
v) = Text -> Value a
forall (s :: Stage). Text -> Value s
mkString Text
v
replaceValue (A.Object Object
v) =
  [(FieldName, Value a)] -> Value a
forall (s :: Stage). [(FieldName, Value s)] -> Value s
mkObject ([(FieldName, Value a)] -> Value a)
-> [(FieldName, Value a)] -> Value a
forall a b. (a -> b) -> a -> b
$
    (Pair -> (FieldName, Value a)) -> [Pair] -> [(FieldName, Value a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ((Text -> FieldName)
-> (Value -> Value a) -> Pair -> (FieldName, Value a)
forall a a' b b'. (a -> a') -> (b -> b') -> (a, b) -> (a', b')
mapTuple Text -> FieldName
FieldName Value -> Value a
forall (a :: Stage). Value -> Value a
replaceValue)
      (Object -> [Pair]
forall k v. HashMap k v -> [(k, v)]
M.toList Object
v)
replaceValue (A.Array Array
li) = [Value a] -> Value a
forall (stage :: Stage). [Value stage] -> Value stage
List ((Value -> Value a) -> [Value] -> [Value a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value a
forall (a :: Stage). Value -> Value a
replaceValue (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
li))
replaceValue Value
A.Null = Value a
forall (stage :: Stage). Value stage
Null

instance A.FromJSON (Value a) where
  parseJSON :: Value -> Parser (Value a)
parseJSON = Value a -> Parser (Value a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value a -> Parser (Value a))
-> (Value -> Value a) -> Value -> Parser (Value a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value a
forall (a :: Stage). Value -> Value a
replaceValue

-- DEFAULT VALUES

mkBoolean :: Bool -> Value s
mkBoolean :: Bool -> Value s
mkBoolean = ScalarValue -> Value s
forall (stage :: Stage). ScalarValue -> Value stage
Scalar (ScalarValue -> Value s)
-> (Bool -> ScalarValue) -> Bool -> Value s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ScalarValue
Boolean

mkString :: Text -> Value s
mkString :: Text -> Value s
mkString = ScalarValue -> Value s
forall (stage :: Stage). ScalarValue -> Value stage
Scalar (ScalarValue -> Value s)
-> (Text -> ScalarValue) -> Text -> Value s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ScalarValue
String

mkObject :: [(FieldName, Value s)] -> Value s
mkObject :: [(FieldName, Value s)] -> Value s
mkObject = Object s -> Value s
forall (stage :: Stage). Object stage -> Value stage
Object (Object s -> Value s)
-> ([(FieldName, Value s)] -> Object s)
-> [(FieldName, Value s)]
-> Value s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FieldName, ObjectEntry s)] -> Object s
forall k a. (Hashable k, Eq k) => [(k, a)] -> OrdMap k a
unsafeFromList ([(FieldName, ObjectEntry s)] -> Object s)
-> ([(FieldName, Value s)] -> [(FieldName, ObjectEntry s)])
-> [(FieldName, Value s)]
-> Object s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName, Value s) -> (FieldName, ObjectEntry s))
-> [(FieldName, Value s)] -> [(FieldName, ObjectEntry s)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldName, Value s) -> (FieldName, ObjectEntry s)
forall (s :: Stage).
(FieldName, Value s) -> (FieldName, ObjectEntry s)
toEntry
  where
    toEntry :: (FieldName, Value s) -> (FieldName, ObjectEntry s)
toEntry (FieldName
key, Value s
value) = (FieldName
key, FieldName -> Value s -> ObjectEntry s
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
key Value s
value)