content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DeriveLift #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE TemplateHaskellQuotes #-}
  {-# 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 Data.Mergeable
    ( NameCollision (..),
      OrdMap,
    )
  import Data.Morpheus.Internal.Utils
    ( KeyOf (..),
      toAssoc,
      unsafeFromList,
    )
  import Data.Morpheus.Rendering.RenderGQL
    ( RenderGQL (..),
      fromText,
      render,
      renderInputSeq,
      space,
    )
  import Data.Morpheus.Types.Internal.AST.Base
    ( Position,
      Ref (..),
    )
  import Data.Morpheus.Types.Internal.AST.Error
    ( GQLError,
      Msg (..),
      at,
    )
  import Data.Morpheus.Types.Internal.AST.Name
    ( FieldName,
      TypeName,
      packName,
      unpackName,
    )
  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.Text as T
  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 (Show, Eq, Generic, Lift)
  
  instance IsString ScalarValue where
    fromString = String . T.pack
  
  instance RenderGQL ScalarValue where
    renderGQL (Int x) = renderGQL x
    renderGQL (Float x) = renderGQL x
    renderGQL (String x) = renderGQL x
    renderGQL (Boolean x) = renderGQL x
    renderGQL (Value x) = renderGQL x
  
  instance A.ToJSON ScalarValue where
    toJSON (Float x) = A.toJSON x
    toJSON (Int x) = A.toJSON x
    toJSON (Boolean x) = A.toJSON x
    toJSON (String x) = A.toJSON x
    toJSON (Value x) = A.toJSON x
  
  instance A.FromJSON ScalarValue where
    parseJSON (A.Bool v) = pure $ Boolean v
    parseJSON (A.Number v) = pure $ decodeScientific v
    parseJSON (A.String v) = pure $ String v
    parseJSON notScalar = fail $ "Expected Scalar got :" <> show notScalar
  
  data VariableContent (stage :: Stage) where
    DefaultValue :: Maybe ResolvedValue -> VariableContent CONST
    ValidVariableValue :: {validVarContent :: ValidValue} -> VariableContent VALID
  
  instance Lift (VariableContent a) where
    lift (DefaultValue x) = [|DefaultValue x|]
    lift (ValidVariableValue x) = [|ValidVariableValue x|]
  
  #if MIN_VERSION_template_haskell(2,16,0)
    liftTyped (DefaultValue x) = [||DefaultValue x||]
    liftTyped (ValidVariableValue x) = [||ValidVariableValue x||]
  #endif
  deriving instance Show (VariableContent a)
  
  deriving instance Eq (VariableContent a)
  
  data Variable (stage :: Stage) = Variable
    { variablePosition :: Position,
      variableName :: FieldName,
      variableType :: TypeRef,
      variableValue :: VariableContent (CONST_OR_VALID stage)
    }
    deriving (Show, Eq, Lift)
  
  instance KeyOf FieldName (Variable s) where
    keyOf = variableName
  
  instance NameCollision GQLError (Variable s) where
    nameCollision Variable {variableName, variablePosition} =
      ("There can Be only One Variable Named " <> msg variableName)
        `at` 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
  
  instance IsString (Value stage) where
    fromString = Scalar . fromString
  
  deriving instance Show (Value a)
  
  deriving instance Eq (Value s)
  
  data ObjectEntry (s :: Stage) = ObjectEntry
    { entryName :: FieldName,
      entryValue :: Value s
    }
    deriving (Eq, Show)
  
  instance RenderGQL (ObjectEntry a) where
    renderGQL (ObjectEntry name value) = fromText (unpackName name) <> ": " <> renderGQL value
  
  instance NameCollision GQLError (ObjectEntry s) where
    nameCollision ObjectEntry {entryName} =
      "There can Be only One field Named "
        <> msg entryName
  
  instance KeyOf FieldName (ObjectEntry s) where
    keyOf = 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 (ResolvedVariable Ref {refName} _) = "$" <> renderGQL refName
    renderGQL (VariableValue Ref {refName}) = "$" <> renderGQL refName <> " "
    renderGQL Null = "null"
    renderGQL (Enum x) = renderGQL x
    renderGQL (Scalar x) = renderGQL x
    renderGQL (Object xs) = "{" <> entries <> "}"
      where
        entries
          | null xs = ""
          | otherwise = space <> renderInputSeq (toList xs) <> space
    renderGQL (List list) = "[" <> renderInputSeq list <> "]"
  
  instance Msg (Value a) where
    msg = msg . render
  
  instance A.ToJSON (Value a) where
    toJSON (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) =
      A.toJSON x
    toJSON (VariableValue Ref {refName}) =
      A.String $ "($ref:" <> unpackName refName <> ")"
    toJSON Null = A.Null
    toJSON (Enum x) = A.String (unpackName x)
    toJSON (Scalar x) = A.toJSON x
    toJSON (List x) = A.toJSON x
    toJSON (Object fields) = A.object $ fmap toEntry (toList fields)
      where
        toEntry (ObjectEntry name value) = unpackName name A..= A.toJSON value
  
    -------------------------------------------
    toEncoding (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) =
      A.toEncoding x
    toEncoding (VariableValue Ref {refName}) =
      A.toEncoding $ "($ref:" <> refName <> ")"
    toEncoding Null = A.toEncoding A.Null
    toEncoding (Enum x) = A.toEncoding x
    toEncoding (Scalar x) = A.toEncoding x
    toEncoding (List x) = A.toEncoding x
    toEncoding (Object ordMap) = A.pairs $ renderSeries encodeField (toList ordMap)
      where
        encodeField (ObjectEntry key value) = unpackName key A..= 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 _ [] = mempty
  renderSeries f (x : xs) = foldr' (\e es -> es <> f e) (f x) xs
  
  decodeScientific :: Scientific -> ScalarValue
  decodeScientific v = case floatingOrInteger v of
    Left float -> Float float
    Right int -> Int int
  
  replaceValue :: A.Value -> Value a
  replaceValue (A.Bool v) = mkBoolean v
  replaceValue (A.Number v) = Scalar $ decodeScientific v
  replaceValue (A.String v) = mkString v
  replaceValue (A.Object v) =
    mkObject
      $ fmap
        (bimap packName replaceValue)
        (toAssoc v)
  replaceValue (A.Array li) = List (fmap replaceValue (V.toList li))
  replaceValue A.Null = Null
  
  instance A.FromJSON (Value a) where
    parseJSON = pure . replaceValue
  
  -- DEFAULT VALUES
  
  mkBoolean :: Bool -> Value s
  mkBoolean = Scalar . Boolean
  
  mkString :: Text -> Value s
  mkString = Scalar . String
  
  mkObject :: [(FieldName, Value s)] -> Value s
  mkObject = Object . unsafeFromList . fmap toEntry
    where
      toEntry (key, value) = (key, ObjectEntry key value)
  
  instance Hashable (Value a) where
    hashWithSalt s (Object x) = hashWithSalt s (0 :: Int, toList x)
    hashWithSalt s (List x) = hashWithSalt s (1 :: Int, x)
    hashWithSalt s (Enum x) = hashWithSalt s (2 :: Int, x)
    hashWithSalt s (Scalar x) = hashWithSalt s (3 :: Int, show x :: String)
    hashWithSalt s Null = hashWithSalt s (4 :: Int)
    hashWithSalt s (ResolvedVariable _ _) = hashWithSalt s (5 :: Int)
    hashWithSalt s (VariableValue Ref {refName}) = hashWithSalt s (6 :: Int, refName)
  
  instance Hashable (ObjectEntry s) where
    hashWithSalt s (ObjectEntry name value) = hashWithSalt s (name, value)
  