{-# 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 x = x {errorType = Just Internal}

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

custom :: GQLError -> Text -> GQLError
custom x customError = x {errorType = Just (Custom customError)}

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

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

at :: GQLError -> Position -> GQLError
at err pos = atPositions err [pos]
{-# INLINE at #-}

atPositions :: Foldable t => GQLError -> t Position -> GQLError
atPositions GQLError {..} pos = case toList pos of
  [] -> GQLError {..}
  posList -> GQLError {locations = locations <> Just posList, ..}
{-# INLINE atPositions #-}


withExtensions :: GQLError -> Map Text Value -> GQLError
withExtensions gqlerr ext = gqlerr { extensions = Just ext }

withPath :: GQLError -> [PropName] -> GQLError
withPath err [] = err
withPath err path = err {path = Just path}

manyMsg :: (Foldable t, Msg a) => t a -> GQLError
manyMsg =
  msg . T.intercalate ", "
    . fmap (message . msg)
    . toList

data ErrorType
  = Internal
  | Custom Text
  deriving
    ( Show,
      Eq,
      Generic
    )

instance ToJSON ErrorType where
  toJSON (Custom customError) = String customError
  toJSON Internal = Null

instance FromJSON ErrorType where
  parseJSON (String customError) = pure $ Custom customError
  parseJSON _ = fail "Unexpected custom error type"

instance Semigroup ErrorType where
  Internal <> _ = Internal
  _ <> Internal = Internal
  Custom customError <> Custom customError' = Custom $ customError <> ", " <> customError'

data GQLError = GQLError
  { message :: Message,
    locations :: Maybe [Position],
    path :: Maybe [PropName],
    errorType :: Maybe ErrorType,
    extensions :: Maybe (Map Text Value)
  }
  deriving
    ( Show,
      Eq,
      Generic
    )

data PropName
  = PropIndex Int
  | PropName Text
  deriving (Show, Eq, Generic)

instance IsString PropName where
  fromString = PropName . T.pack

instance FromJSON PropName where
  parseJSON (String name) = pure (PropName name)
  parseJSON (Number v) = case floatingOrInteger v of
    Left fl -> invalidIndex fl
    Right index -> pure (PropIndex index)
  parseJSON _ = fail "Property Name must be a either Name or Index"

invalidIndex :: MonadFail m => Double -> m a
invalidIndex i = fail $ "Property Name must be a either Name or Index. it can't be " <> show i <> "."

instance ToJSON PropName where
  toJSON (PropName name) = toJSON name
  toJSON (PropIndex index) = toJSON index

instance Ord GQLError where
  compare x y = compare (locations x) (locations y) <> compare (message x) (message y)

instance IsString GQLError where
  fromString = msg

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

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

instance ToJSON GQLError where
  toJSON = genericToJSON aesonOptions

instance FromJSON GQLError where
  parseJSON = genericParseJSON aesonOptions

instance Semigroup GQLError where
  GQLError m1 l1 p1 t1 e1 <> GQLError m2 l2 p2 t2 e2 = GQLError (m1 <> m2) (l1 <> l2) (p1 <> p2) (t1 <> t2) (e1 <> e2)

type GQLErrors = NonEmpty GQLError

class Msg a where
  msg :: a -> GQLError

instance Msg GQLError where
  msg = id

instance Msg String where
  msg = msg . T.pack

instance Msg Text where
  msg message =
    GQLError
      { message,
        locations = Nothing,
        errorType = Nothing,
        extensions = Nothing,
        path = Nothing
      }

instance Msg ByteString where
  msg = msg . LT.toStrict . decodeUtf8

instance Msg Value where
  msg = msg . encode