{-# LANGUAGE QuasiQuotes #-}

-- | This module defines the scalars we use specific to the BigQuery
-- schema.
--
-- An idiosyncracy of BigQuery is that numbers serialized via JSON uses string
-- literals instead of number literals, because BigQuery handles wider-bit
-- numbers than JSON/JavaScript does.
--
-- Therefore, the BigQuery Backend uses bespoke parsers for numeric scalar
-- input, which accept string literals as well as number literals, such that we
-- preserve symmetry with with output formats.
module Hasura.Backends.BigQuery.Parser.Scalars
  ( bqInt64,
    bqFloat64,
    bqDecimal,
    bqBigDecimal,
  )
where

import Data.Aeson qualified as J
import Data.Int (Int64)
import Data.Scientific (Scientific)
import Data.Scientific qualified as S
import Data.Scientific qualified as Scientific
import Data.Text qualified as Text
import Hasura.Backends.BigQuery.Types qualified as BigQuery
import Hasura.Base.ErrorMessage (toErrorMessage)
import Hasura.Base.ErrorValue (dquote)
import Hasura.GraphQL.Parser.Class
import Hasura.GraphQL.Parser.ErrorCode
import Hasura.GraphQL.Parser.Internal.TypeChecking
import Hasura.GraphQL.Parser.Internal.Types
import Hasura.GraphQL.Parser.Schema
import Hasura.GraphQL.Parser.Variable
import Hasura.Prelude
import Language.GraphQL.Draft.Syntax hiding (Definition)
import Language.GraphQL.Draft.Syntax qualified as G
import Language.GraphQL.Draft.Syntax.QQ qualified as G
import Text.ParserCombinators.ReadP

bqInt64 :: forall origin m. (MonadParse m) => Parser origin 'Both m BigQuery.Int64
bqInt64 :: forall origin (m :: * -> *).
MonadParse m =>
Parser origin 'Both m Int64
bqInt64 = Name
-> Description
-> (InputValue Variable -> m Int64)
-> Parser origin 'Both m Int64
forall (m :: * -> *) a origin.
MonadParse m =>
Name
-> Description
-> (InputValue Variable -> m a)
-> Parser origin 'Both m a
mkScalar Name
name Description
"64-bit integers. Accepts both string and number literals." \case
  GraphQLValue (VInt Integer
i)
    | Integer -> Bool
checkIntegerBounds Integer
i -> Int64 -> m Int64
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> m Int64) -> Int64 -> m Int64
forall a b. (a -> b) -> a -> b
$ Text -> Int64
BigQuery.Int64 (Integer -> Text
forall a. Show a => a -> Text
tshow Integer
i)
    | Bool
otherwise -> Text -> m Int64
forall a. Text -> m a
boundsFailure (Integer -> Text
forall a. Show a => a -> Text
tshow Integer
i)
  GraphQLValue (VString Text
s) -> Text -> m Int64
integralText Text
s
  JSONValue (J.String Text
s) -> Text -> m Int64
integralText Text
s
  JSONValue (J.Number Scientific
n) -> Text -> Scientific -> m Int64
integralSci (Scientific -> Text
forall a. Show a => a -> Text
tshow Scientific
n) Scientific
n
  InputValue Variable
v -> Name -> ErrorMessage -> InputValue Variable -> m Int64
forall n (m :: * -> *) a.
(HasName n, MonadParse m) =>
n -> ErrorMessage -> InputValue Variable -> m a
typeMismatch Name
name ErrorMessage
"a 64-bit integer" InputValue Variable
v
  where
    name :: Name
name = [G.name|bigquery_int|]

    checkIntegerBounds :: Integer -> Bool
    checkIntegerBounds :: Integer -> Bool
checkIntegerBounds Integer
i = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound @Int64) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound @Int64)

    integralText :: Text -> m BigQuery.Int64
    integralText :: Text -> m Int64
integralText Text
inputText
      | [(Scientific
sci, String
"")] <- ReadP Scientific -> ReadS Scientific
forall a. ReadP a -> ReadS a
readP_to_S ReadP Scientific
Scientific.scientificP (Text -> String
Text.unpack Text
inputText) = Text -> Scientific -> m Int64
integralSci Text
inputText Scientific
sci
      | Bool
otherwise = Name -> Text -> m Int64
forall (m :: * -> *) a. MonadParse m => Name -> Text -> m a
stringNotationError Name
name Text
inputText

    integralSci :: Text -> Scientific -> m BigQuery.Int64
    integralSci :: Text -> Scientific -> m Int64
integralSci Text
inputText Scientific
sci
      | Scientific -> Bool
Scientific.isInteger Scientific
sci =
          case forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Scientific.toBoundedInteger @Int64 Scientific
sci of
            Just Int64
v -> Int64 -> m Int64
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> m Int64) -> Int64 -> m Int64
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64
BigQuery.intToInt64 Int64
v
            Maybe Int64
Nothing -> Text -> m Int64
forall a. Text -> m a
boundsFailure Text
inputText
      | Bool
otherwise = Text -> m Int64
forall a. Text -> m a
integralFailure Text
inputText

    boundsFailure, integralFailure :: forall a. Text -> m a
    boundsFailure :: forall a. Text -> m a
boundsFailure Text
inputText = ParseErrorCode -> ErrorMessage -> m a
forall a. ParseErrorCode -> ErrorMessage -> m a
forall (m :: * -> *) a.
MonadParse m =>
ParseErrorCode -> ErrorMessage -> m a
parseErrorWith ParseErrorCode
ParseFailed (ErrorMessage -> m a) -> ErrorMessage -> m a
forall a b. (a -> b) -> a -> b
$ ErrorMessage
"The value " ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> Text -> ErrorMessage
toErrorMessage Text
inputText ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> ErrorMessage
" lies outside the accepted numerical integral bounds."
    integralFailure :: forall a. Text -> m a
integralFailure Text
inputText = ParseErrorCode -> ErrorMessage -> m a
forall a. ParseErrorCode -> ErrorMessage -> m a
forall (m :: * -> *) a.
MonadParse m =>
ParseErrorCode -> ErrorMessage -> m a
parseErrorWith ParseErrorCode
ParseFailed (ErrorMessage -> m a) -> ErrorMessage -> m a
forall a b. (a -> b) -> a -> b
$ ErrorMessage
"The value " ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> Text -> ErrorMessage
toErrorMessage Text
inputText ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> ErrorMessage
" has a non-zero fractional part."

bqFloat64 :: forall origin m. (MonadParse m) => Parser origin 'Both m BigQuery.Float64
bqFloat64 :: forall origin (m :: * -> *).
MonadParse m =>
Parser origin 'Both m Float64
bqFloat64 = Name
-> Description
-> (InputValue Variable -> m Float64)
-> Parser origin 'Both m Float64
forall (m :: * -> *) a origin.
MonadParse m =>
Name
-> Description
-> (InputValue Variable -> m a)
-> Parser origin 'Both m a
mkScalar Name
name Description
"64-bit floats. Accepts both string and number literals." \case
  GraphQLValue (VFloat Scientific
f) -> Text -> Scientific -> m Float64
floatSci (Scientific -> Text
forall a. Show a => a -> Text
tshow Scientific
f) Scientific
f
  GraphQLValue (VInt Integer
i) -> Text -> Scientific -> m Float64
floatSci (Integer -> Text
forall a. Show a => a -> Text
tshow Integer
i) (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
i)
  GraphQLValue (VString Text
s) -> Text -> m Float64
floatText Text
s
  JSONValue (J.String Text
s) -> Text -> m Float64
floatText Text
s
  JSONValue (J.Number Scientific
n) -> Text -> Scientific -> m Float64
floatSci (Scientific -> Text
forall a. Show a => a -> Text
tshow Scientific
n) Scientific
n
  InputValue Variable
v -> Name -> ErrorMessage -> InputValue Variable -> m Float64
forall n (m :: * -> *) a.
(HasName n, MonadParse m) =>
n -> ErrorMessage -> InputValue Variable -> m a
typeMismatch Name
name ErrorMessage
"a 64-bit float" InputValue Variable
v
  where
    name :: Name
name = [G.name|bigquery_float|]

    floatText :: Text -> m BigQuery.Float64
    floatText :: Text -> m Float64
floatText Text
inputText
      | [(Scientific
sci, String
"")] <- ReadP Scientific -> ReadS Scientific
forall a. ReadP a -> ReadS a
readP_to_S ReadP Scientific
Scientific.scientificP (Text -> String
Text.unpack Text
inputText) = Text -> Scientific -> m Float64
floatSci Text
inputText Scientific
sci
      | Bool
otherwise = Name -> Text -> m Float64
forall (m :: * -> *) a. MonadParse m => Name -> Text -> m a
stringNotationError Name
name Text
inputText

    floatSci :: Text -> Scientific -> m BigQuery.Float64
    floatSci :: Text -> Scientific -> m Float64
floatSci Text
inputText Scientific
sci =
      case forall a. RealFloat a => Scientific -> Either a a
Scientific.toBoundedRealFloat @Double Scientific
sci of
        Right Double
v -> Float64 -> m Float64
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Float64 -> m Float64) -> Float64 -> m Float64
forall a b. (a -> b) -> a -> b
$ Double -> Float64
BigQuery.doubleToFloat64 Double
v
        Left Double
_ -> Text -> m Float64
forall a. Text -> m a
boundsFailure Text
inputText

    boundsFailure :: forall a. Text -> m a
    boundsFailure :: forall a. Text -> m a
boundsFailure Text
inputText = ParseErrorCode -> ErrorMessage -> m a
forall a. ParseErrorCode -> ErrorMessage -> m a
forall (m :: * -> *) a.
MonadParse m =>
ParseErrorCode -> ErrorMessage -> m a
parseErrorWith ParseErrorCode
ParseFailed (ErrorMessage -> m a) -> ErrorMessage -> m a
forall a b. (a -> b) -> a -> b
$ ErrorMessage
"The value " ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> Text -> ErrorMessage
toErrorMessage Text
inputText ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> ErrorMessage
" lies outside the accepted numerical integral bounds."

bqBigDecimal :: (MonadParse m) => Parser origin 'Both m BigQuery.BigDecimal
bqBigDecimal :: forall (m :: * -> *) origin.
MonadParse m =>
Parser origin 'Both m BigDecimal
bqBigDecimal = Name
-> Description
-> (InputValue Variable -> m BigDecimal)
-> Parser origin 'Both m BigDecimal
forall (m :: * -> *) a origin.
MonadParse m =>
Name
-> Description
-> (InputValue Variable -> m a)
-> Parser origin 'Both m a
mkScalar Name
name Description
"BigDecimals. Accepts both string and number literals." ((InputValue Variable -> m BigDecimal)
 -> Parser origin 'Both m BigDecimal)
-> (InputValue Variable -> m BigDecimal)
-> Parser origin 'Both m BigDecimal
forall a b. (a -> b) -> a -> b
$ (Scientific -> BigDecimal) -> m Scientific -> m BigDecimal
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> BigDecimal
BigQuery.BigDecimal (Text -> BigDecimal)
-> (Scientific -> Text) -> Scientific -> BigDecimal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Text
BigQuery.scientificToText) (m Scientific -> m BigDecimal)
-> (InputValue Variable -> m Scientific)
-> InputValue Variable
-> m BigDecimal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> InputValue Variable -> m Scientific
forall (f :: * -> *).
MonadParse f =>
Name -> InputValue Variable -> f Scientific
decimal Name
name
  where
    name :: Name
name = [G.name|bigquery_bigdecimal|]

bqDecimal :: (MonadParse m) => Parser origin 'Both m BigQuery.Decimal
bqDecimal :: forall (m :: * -> *) origin.
MonadParse m =>
Parser origin 'Both m Decimal
bqDecimal = Name
-> Description
-> (InputValue Variable -> m Decimal)
-> Parser origin 'Both m Decimal
forall (m :: * -> *) a origin.
MonadParse m =>
Name
-> Description
-> (InputValue Variable -> m a)
-> Parser origin 'Both m a
mkScalar Name
name Description
"Decimals. Accepts both string and number literals." ((InputValue Variable -> m Decimal)
 -> Parser origin 'Both m Decimal)
-> (InputValue Variable -> m Decimal)
-> Parser origin 'Both m Decimal
forall a b. (a -> b) -> a -> b
$ (Scientific -> Decimal) -> m Scientific -> m Decimal
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Decimal
BigQuery.Decimal (Text -> Decimal) -> (Scientific -> Text) -> Scientific -> Decimal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Text
BigQuery.scientificToText) (m Scientific -> m Decimal)
-> (InputValue Variable -> m Scientific)
-> InputValue Variable
-> m Decimal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> InputValue Variable -> m Scientific
forall (f :: * -> *).
MonadParse f =>
Name -> InputValue Variable -> f Scientific
decimal Name
name
  where
    name :: Name
name = [G.name|bigquery_decimal|]

decimal :: (MonadParse f) => Name -> InputValue Variable -> f Scientific
decimal :: forall (f :: * -> *).
MonadParse f =>
Name -> InputValue Variable -> f Scientific
decimal Name
name = \case
  GraphQLValue (VFloat Scientific
f) -> Scientific -> f Scientific
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
f
  GraphQLValue (VInt Integer
i) -> Scientific -> f Scientific
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> f Scientific) -> Scientific -> f Scientific
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Scientific
S.scientific Integer
i Int
0
  GraphQLValue (VString Text
s)
    | Just Scientific
sci <- String -> Maybe Scientific
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
s) -> Scientific -> f Scientific
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> f Scientific) -> Scientific -> f Scientific
forall a b. (a -> b) -> a -> b
$ Scientific
sci
    | Bool
otherwise -> Name -> Text -> f Scientific
forall (m :: * -> *) a. MonadParse m => Name -> Text -> m a
stringNotationError Name
name Text
s
  JSONValue (J.Number Scientific
n) -> Scientific -> f Scientific
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
n
  JSONValue (J.String Text
s)
    | Just Scientific
sci <- String -> Maybe Scientific
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
s) -> Scientific -> f Scientific
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> f Scientific) -> Scientific -> f Scientific
forall a b. (a -> b) -> a -> b
$ Scientific
sci
    | Bool
otherwise -> Name -> Text -> f Scientific
forall (m :: * -> *) a. MonadParse m => Name -> Text -> m a
stringNotationError Name
name Text
s
  InputValue Variable
v -> Name -> ErrorMessage -> InputValue Variable -> f Scientific
forall n (m :: * -> *) a.
(HasName n, MonadParse m) =>
n -> ErrorMessage -> InputValue Variable -> m a
typeMismatch Name
name ErrorMessage
"decimal" InputValue Variable
v

--------------------------------------------------------------------------------
-- Local helpers

mkScalar ::
  (MonadParse m) =>
  Name ->
  Description ->
  (InputValue Variable -> m a) ->
  Parser origin 'Both m a
mkScalar :: forall (m :: * -> *) a origin.
MonadParse m =>
Name
-> Description
-> (InputValue Variable -> m a)
-> Parser origin 'Both m a
mkScalar Name
name Description
desc InputValue Variable -> m a
parser =
  Parser
    { pType :: Type origin 'Both
pType = Type origin 'Both
schemaType,
      pParser :: ParserInput 'Both -> m a
pParser = GType -> InputValue Variable -> m (InputValue Variable)
forall (m :: * -> *).
MonadParse m =>
GType -> InputValue Variable -> m (InputValue Variable)
peelVariable (Type origin 'Both -> GType
forall origin (k :: Kind). Type origin k -> GType
toGraphQLType Type origin 'Both
schemaType) (InputValue Variable -> m (InputValue Variable))
-> (InputValue Variable -> m a) -> InputValue Variable -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> InputValue Variable -> m a
parser
    }
  where
    schemaType :: Type origin 'Both
schemaType = Name -> Maybe Description -> Type origin 'Both
forall origin. Name -> Maybe Description -> Type origin 'Both
typeNamed Name
name (Description -> Maybe Description
forall a. a -> Maybe a
Just Description
desc)

typeNamed :: Name -> Maybe Description -> Type origin 'Both
typeNamed :: forall origin. Name -> Maybe Description -> Type origin 'Both
typeNamed Name
name Maybe Description
description = Nullability
-> Definition origin (TypeInfo origin 'Both) -> Type origin 'Both
forall origin (k :: Kind).
Nullability
-> Definition origin (TypeInfo origin k) -> Type origin k
TNamed Nullability
NonNullable (Definition origin (TypeInfo origin 'Both) -> Type origin 'Both)
-> Definition origin (TypeInfo origin 'Both) -> Type origin 'Both
forall a b. (a -> b) -> a -> b
$ Name
-> Maybe Description
-> Maybe origin
-> [Directive Void]
-> TypeInfo origin 'Both
-> Definition origin (TypeInfo origin 'Both)
forall origin a.
Name
-> Maybe Description
-> Maybe origin
-> [Directive Void]
-> a
-> Definition origin a
Definition Name
name Maybe Description
description Maybe origin
forall a. Maybe a
Nothing [] TypeInfo origin 'Both
forall origin. TypeInfo origin 'Both
TIScalar

stringNotationError :: (MonadParse m) => G.Name -> Text -> m a
stringNotationError :: forall (m :: * -> *) a. MonadParse m => Name -> Text -> m a
stringNotationError Name
typeName Text
actualString =
  ErrorMessage -> m a
forall (m :: * -> *) a. MonadParse m => ErrorMessage -> m a
parseError
    (ErrorMessage -> m a) -> ErrorMessage -> m a
forall a b. (a -> b) -> a -> b
$ ErrorMessage
"expected "
    ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> Text -> ErrorMessage
toErrorMessage (Name -> Text
forall a. Show a => a -> Text
tshow Name
typeName)
    ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> ErrorMessage
" represented as a string, but got "
    ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> Text -> ErrorMessage
dquote Text
actualString
    ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> ErrorMessage
", which is not a recognizable "
    ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> Text -> ErrorMessage
toErrorMessage (Name -> Text
forall a. Show a => a -> Text
tshow Name
typeName)
    ErrorMessage -> ErrorMessage -> ErrorMessage
forall a. Semigroup a => a -> a -> a
<> ErrorMessage
"."