{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.AST.Error
  ( at,
    atPositions,
    custom,
    isCustom,
    internal,
    isInternal,
    getCustomErrorType,
    GQLErrors,
    GQLError
      ( message,
        locations
      ),
    manyMsg,
    Msg (..),
    Message,
    withPath,
    withExtensions,
    PropName (..),
  )
where

import Data.Aeson
  ( FromJSON (..),
    Options (..),
    ToJSON (..),
    Value (Null, Number, String),
    defaultOptions,
    encode,
    genericParseJSON,
    genericToJSON,
  )
import Data.ByteString.Lazy (ByteString)
import Data.Morpheus.Types.Internal.AST.Base
  ( Position (..),
  )
import Data.Scientific (floatingOrInteger)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Encoding (decodeUtf8)
import Relude hiding (ByteString, decodeUtf8)

type Message = Text

internal :: GQLError -> GQLError
internal :: GQLError -> GQLError
internal GQLError
x = GQLError
x {errorType :: Maybe ErrorType
errorType = ErrorType -> Maybe ErrorType
forall a. a -> Maybe a
Just ErrorType
Internal}

isInternal :: GQLError -> Bool
isInternal :: GQLError -> Bool
isInternal GQLError {errorType :: GQLError -> Maybe ErrorType
errorType = Just ErrorType
Internal} = Bool
True
isInternal GQLError
_ = Bool
False

custom :: GQLError -> Text -> GQLError
custom :: GQLError -> Text -> GQLError
custom GQLError
x Text
customError = GQLError
x {errorType :: Maybe ErrorType
errorType = ErrorType -> Maybe ErrorType
forall a. a -> Maybe a
Just (Text -> ErrorType
Custom Text
customError)}

isCustom :: GQLError -> Bool
isCustom :: GQLError -> Bool
isCustom GQLError {errorType :: GQLError -> Maybe ErrorType
errorType = Just (Custom Text
_)} = Bool
True
isCustom GQLError
_ = Bool
False

getCustomErrorType :: GQLError -> Maybe Text
getCustomErrorType :: GQLError -> Maybe Text
getCustomErrorType GQLError {errorType :: GQLError -> Maybe ErrorType
errorType = Just (Custom Text
customError)} = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
customError
getCustomErrorType GQLError
_ = Maybe Text
forall a. Maybe a
Nothing

at :: GQLError -> Position -> GQLError
at :: GQLError -> Position -> GQLError
at GQLError
err Position
pos = GQLError -> [Position] -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
atPositions GQLError
err [Position
pos]
{-# INLINE at #-}

atPositions :: Foldable t => GQLError -> t Position -> GQLError
atPositions :: GQLError -> t Position -> GQLError
atPositions GQLError {Maybe [Position]
Maybe [PropName]
Maybe (Map Text Value)
Maybe ErrorType
Text
extensions :: GQLError -> Maybe (Map Text Value)
path :: GQLError -> Maybe [PropName]
extensions :: Maybe (Map Text Value)
errorType :: Maybe ErrorType
path :: Maybe [PropName]
locations :: Maybe [Position]
message :: Text
errorType :: GQLError -> Maybe ErrorType
locations :: GQLError -> Maybe [Position]
message :: GQLError -> Text
..} t Position
pos = case t Position -> [Position]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t Position
pos of
  [] -> GQLError :: Text
-> Maybe [Position]
-> Maybe [PropName]
-> Maybe ErrorType
-> Maybe (Map Text Value)
-> GQLError
GQLError {Maybe [Position]
Maybe [PropName]
Maybe (Map Text Value)
Maybe ErrorType
Text
extensions :: Maybe (Map Text Value)
path :: Maybe [PropName]
extensions :: Maybe (Map Text Value)
errorType :: Maybe ErrorType
path :: Maybe [PropName]
locations :: Maybe [Position]
message :: Text
errorType :: Maybe ErrorType
locations :: Maybe [Position]
message :: Text
..}
  [Position]
posList -> GQLError :: Text
-> Maybe [Position]
-> Maybe [PropName]
-> Maybe ErrorType
-> Maybe (Map Text Value)
-> GQLError
GQLError {locations :: Maybe [Position]
locations = Maybe [Position]
locations Maybe [Position] -> Maybe [Position] -> Maybe [Position]
forall a. Semigroup a => a -> a -> a
<> [Position] -> Maybe [Position]
forall a. a -> Maybe a
Just [Position]
posList, Maybe [PropName]
Maybe (Map Text Value)
Maybe ErrorType
Text
extensions :: Maybe (Map Text Value)
path :: Maybe [PropName]
extensions :: Maybe (Map Text Value)
errorType :: Maybe ErrorType
path :: Maybe [PropName]
message :: Text
errorType :: Maybe ErrorType
message :: Text
..}
{-# INLINE atPositions #-}


withExtensions :: GQLError -> Map Text Value -> GQLError
withExtensions :: GQLError -> Map Text Value -> GQLError
withExtensions GQLError
gqlerr Map Text Value
ext = GQLError
gqlerr { extensions :: Maybe (Map Text Value)
extensions = Map Text Value -> Maybe (Map Text Value)
forall a. a -> Maybe a
Just Map Text Value
ext }

withPath :: GQLError -> [PropName] -> GQLError
withPath :: GQLError -> [PropName] -> GQLError
withPath GQLError
err [] = GQLError
err
withPath GQLError
err [PropName]
path = GQLError
err {path :: Maybe [PropName]
path = [PropName] -> Maybe [PropName]
forall a. a -> Maybe a
Just [PropName]
path}

manyMsg :: (Foldable t, Msg a) => t a -> GQLError
manyMsg :: t a -> GQLError
manyMsg =
  Text -> GQLError
forall a. Msg a => a -> GQLError
msg (Text -> GQLError) -> (t a -> Text) -> t a -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
", "
    ([Text] -> Text) -> (t a -> [Text]) -> t a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Text) -> [a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GQLError -> Text
message (GQLError -> Text) -> (a -> GQLError) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> GQLError
forall a. Msg a => a -> GQLError
msg)
    ([a] -> [Text]) -> (t a -> [a]) -> t a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

data ErrorType
  = Internal
  | Custom Text
  deriving
    ( Int -> ErrorType -> ShowS
[ErrorType] -> ShowS
ErrorType -> String
(Int -> ErrorType -> ShowS)
-> (ErrorType -> String)
-> ([ErrorType] -> ShowS)
-> Show ErrorType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorType] -> ShowS
$cshowList :: [ErrorType] -> ShowS
show :: ErrorType -> String
$cshow :: ErrorType -> String
showsPrec :: Int -> ErrorType -> ShowS
$cshowsPrec :: Int -> ErrorType -> ShowS
Show,
      ErrorType -> ErrorType -> Bool
(ErrorType -> ErrorType -> Bool)
-> (ErrorType -> ErrorType -> Bool) -> Eq ErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorType -> ErrorType -> Bool
$c/= :: ErrorType -> ErrorType -> Bool
== :: ErrorType -> ErrorType -> Bool
$c== :: ErrorType -> ErrorType -> Bool
Eq,
      (forall x. ErrorType -> Rep ErrorType x)
-> (forall x. Rep ErrorType x -> ErrorType) -> Generic ErrorType
forall x. Rep ErrorType x -> ErrorType
forall x. ErrorType -> Rep ErrorType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrorType x -> ErrorType
$cfrom :: forall x. ErrorType -> Rep ErrorType x
Generic
    )

instance ToJSON ErrorType where
  toJSON :: ErrorType -> Value
toJSON (Custom Text
customError) = Text -> Value
String Text
customError
  toJSON ErrorType
Internal = Value
Null

instance FromJSON ErrorType where
  parseJSON :: Value -> Parser ErrorType
parseJSON (String Text
customError) = ErrorType -> Parser ErrorType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorType -> Parser ErrorType) -> ErrorType -> Parser ErrorType
forall a b. (a -> b) -> a -> b
$ Text -> ErrorType
Custom Text
customError
  parseJSON Value
_ = String -> Parser ErrorType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected custom error type"

instance Semigroup ErrorType where
  ErrorType
Internal <> :: ErrorType -> ErrorType -> ErrorType
<> ErrorType
_ = ErrorType
Internal
  ErrorType
_ <> ErrorType
Internal = ErrorType
Internal
  Custom Text
customError <> Custom Text
customError' = Text -> ErrorType
Custom (Text -> ErrorType) -> Text -> ErrorType
forall a b. (a -> b) -> a -> b
$ Text
customError Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
customError'

data GQLError = GQLError
  { GQLError -> Text
message :: Message,
    GQLError -> Maybe [Position]
locations :: Maybe [Position],
    GQLError -> Maybe [PropName]
path :: Maybe [PropName],
    GQLError -> Maybe ErrorType
errorType :: Maybe ErrorType,
    GQLError -> Maybe (Map Text Value)
extensions :: Maybe (Map Text Value)
  }
  deriving
    ( Int -> GQLError -> ShowS
[GQLError] -> ShowS
GQLError -> String
(Int -> GQLError -> ShowS)
-> (GQLError -> String) -> ([GQLError] -> ShowS) -> Show GQLError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GQLError] -> ShowS
$cshowList :: [GQLError] -> ShowS
show :: GQLError -> String
$cshow :: GQLError -> String
showsPrec :: Int -> GQLError -> ShowS
$cshowsPrec :: Int -> GQLError -> ShowS
Show,
      GQLError -> GQLError -> Bool
(GQLError -> GQLError -> Bool)
-> (GQLError -> GQLError -> Bool) -> Eq GQLError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GQLError -> GQLError -> Bool
$c/= :: GQLError -> GQLError -> Bool
== :: GQLError -> GQLError -> Bool
$c== :: GQLError -> GQLError -> Bool
Eq,
      (forall x. GQLError -> Rep GQLError x)
-> (forall x. Rep GQLError x -> GQLError) -> Generic GQLError
forall x. Rep GQLError x -> GQLError
forall x. GQLError -> Rep GQLError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GQLError x -> GQLError
$cfrom :: forall x. GQLError -> Rep GQLError x
Generic
    )

data PropName
  = PropIndex Int
  | PropName Text
  deriving (Int -> PropName -> ShowS
[PropName] -> ShowS
PropName -> String
(Int -> PropName -> ShowS)
-> (PropName -> String) -> ([PropName] -> ShowS) -> Show PropName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PropName] -> ShowS
$cshowList :: [PropName] -> ShowS
show :: PropName -> String
$cshow :: PropName -> String
showsPrec :: Int -> PropName -> ShowS
$cshowsPrec :: Int -> PropName -> ShowS
Show, PropName -> PropName -> Bool
(PropName -> PropName -> Bool)
-> (PropName -> PropName -> Bool) -> Eq PropName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PropName -> PropName -> Bool
$c/= :: PropName -> PropName -> Bool
== :: PropName -> PropName -> Bool
$c== :: PropName -> PropName -> Bool
Eq, (forall x. PropName -> Rep PropName x)
-> (forall x. Rep PropName x -> PropName) -> Generic PropName
forall x. Rep PropName x -> PropName
forall x. PropName -> Rep PropName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PropName x -> PropName
$cfrom :: forall x. PropName -> Rep PropName x
Generic)

instance IsString PropName where
  fromString :: String -> PropName
fromString = Text -> PropName
PropName (Text -> PropName) -> (String -> Text) -> String -> PropName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance FromJSON PropName where
  parseJSON :: Value -> Parser PropName
parseJSON (String Text
name) = PropName -> Parser PropName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> PropName
PropName Text
name)
  parseJSON (Number Scientific
v) = case Scientific -> Either Double Int
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
v of
    Left Double
fl -> Double -> Parser PropName
forall (m :: * -> *) a. MonadFail m => Double -> m a
invalidIndex Double
fl
    Right Int
index -> PropName -> Parser PropName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> PropName
PropIndex Int
index)
  parseJSON Value
_ = String -> Parser PropName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Property Name must be a either Name or Index"

invalidIndex :: MonadFail m => Double -> m a
invalidIndex :: Double -> m a
invalidIndex Double
i = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Property Name must be a either Name or Index. it can't be " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall b a. (Show a, IsString b) => a -> b
show Double
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."

instance ToJSON PropName where
  toJSON :: PropName -> Value
toJSON (PropName Text
name) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
name
  toJSON (PropIndex Int
index) = Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
index

instance Ord GQLError where
  compare :: GQLError -> GQLError -> Ordering
compare GQLError
x GQLError
y = Maybe [Position] -> Maybe [Position] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (GQLError -> Maybe [Position]
locations GQLError
x) (GQLError -> Maybe [Position]
locations GQLError
y) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (GQLError -> Text
message GQLError
x) (GQLError -> Text
message GQLError
y)

instance IsString GQLError where
  fromString :: String -> GQLError
fromString = String -> GQLError
forall a. Msg a => a -> GQLError
msg

-- cannot have 'type' as the record name, this is less painful than
-- manually writing to/from JSON instances
stripErrorPrefix :: String -> String
stripErrorPrefix :: ShowS
stripErrorPrefix String
"errorType" = String
"type"
stripErrorPrefix String
other = String
other

aesonOptions :: Options
aesonOptions :: Options
aesonOptions = Options
defaultOptions {omitNothingFields :: Bool
omitNothingFields = Bool
True, fieldLabelModifier :: ShowS
fieldLabelModifier = ShowS
stripErrorPrefix}

instance ToJSON GQLError where
  toJSON :: GQLError -> Value
toJSON = Options -> GQLError -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
aesonOptions

instance FromJSON GQLError where
  parseJSON :: Value -> Parser GQLError
parseJSON = Options -> Value -> Parser GQLError
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
aesonOptions

instance Semigroup GQLError where
  GQLError Text
m1 Maybe [Position]
l1 Maybe [PropName]
p1 Maybe ErrorType
t1 Maybe (Map Text Value)
e1 <> :: GQLError -> GQLError -> GQLError
<> GQLError Text
m2 Maybe [Position]
l2 Maybe [PropName]
p2 Maybe ErrorType
t2 Maybe (Map Text Value)
e2 = Text
-> Maybe [Position]
-> Maybe [PropName]
-> Maybe ErrorType
-> Maybe (Map Text Value)
-> GQLError
GQLError (Text
m1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
m2) (Maybe [Position]
l1 Maybe [Position] -> Maybe [Position] -> Maybe [Position]
forall a. Semigroup a => a -> a -> a
<> Maybe [Position]
l2) (Maybe [PropName]
p1 Maybe [PropName] -> Maybe [PropName] -> Maybe [PropName]
forall a. Semigroup a => a -> a -> a
<> Maybe [PropName]
p2) (Maybe ErrorType
t1 Maybe ErrorType -> Maybe ErrorType -> Maybe ErrorType
forall a. Semigroup a => a -> a -> a
<> Maybe ErrorType
t2) (Maybe (Map Text Value)
e1 Maybe (Map Text Value)
-> Maybe (Map Text Value) -> Maybe (Map Text Value)
forall a. Semigroup a => a -> a -> a
<> Maybe (Map Text Value)
e2)

type GQLErrors = NonEmpty GQLError

class Msg a where
  msg :: a -> GQLError

instance Msg GQLError where
  msg :: GQLError -> GQLError
msg = GQLError -> GQLError
forall a. a -> a
id

instance Msg String where
  msg :: String -> GQLError
msg = Text -> GQLError
forall a. Msg a => a -> GQLError
msg (Text -> GQLError) -> (String -> Text) -> String -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance Msg Text where
  msg :: Text -> GQLError
msg Text
message =
    GQLError :: Text
-> Maybe [Position]
-> Maybe [PropName]
-> Maybe ErrorType
-> Maybe (Map Text Value)
-> GQLError
GQLError
      { Text
message :: Text
message :: Text
message,
        locations :: Maybe [Position]
locations = Maybe [Position]
forall a. Maybe a
Nothing,
        errorType :: Maybe ErrorType
errorType = Maybe ErrorType
forall a. Maybe a
Nothing,
        extensions :: Maybe (Map Text Value)
extensions = Maybe (Map Text Value)
forall a. Maybe a
Nothing,
        path :: Maybe [PropName]
path = Maybe [PropName]
forall a. Maybe a
Nothing
      }

instance Msg ByteString where
  msg :: ByteString -> GQLError
msg = Text -> GQLError
forall a. Msg a => a -> GQLError
msg (Text -> GQLError)
-> (ByteString -> Text) -> ByteString -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8

instance Msg Value where
  msg :: Value -> GQLError
msg = ByteString -> GQLError
forall a. Msg a => a -> GQLError
msg (ByteString -> GQLError)
-> (Value -> ByteString) -> Value -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode