{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.AST.Type
  ( TypeRef (..),
    TypeWrapper (..),
    Nullable (..),
    Strictness (..),
    TypeKind (..),
    Subtyping (..),
    mkTypeRef,
    mkBaseType,
    mkMaybeType,
  )
where

import Data.Morpheus.Rendering.RenderGQL
  ( RenderGQL (..),
    Rendering,
    render,
    renderGQL,
  )
import Data.Morpheus.Types.Internal.AST.Error
  ( Msg (..),
  )
import Data.Morpheus.Types.Internal.AST.Name
  ( TypeName,
    packName,
  )
import Data.Morpheus.Types.Internal.AST.OperationType
  ( OperationType (..),
  )
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Encoding (decodeUtf8)
import Language.Haskell.TH.Syntax (Lift (..))
import Relude hiding
  ( ByteString,
    decodeUtf8,
    intercalate,
  )

-- Kind
-----------------------------------------------------------------------------------
data TypeKind
  = KIND_SCALAR
  | KIND_ENUM
  | KIND_OBJECT (Maybe OperationType)
  | KIND_INPUT_OBJECT
  | KIND_UNION
  | KIND_INPUT_UNION
  | KIND_LIST
  | KIND_NON_NULL
  | KIND_INTERFACE
  deriving (Eq, Show, Lift)

instance RenderGQL TypeKind where
  renderGQL KIND_SCALAR = "SCALAR"
  renderGQL KIND_ENUM = "ENUM"
  renderGQL KIND_OBJECT {} = "OBJECT"
  renderGQL KIND_INPUT_OBJECT = "INPUT_OBJECT"
  renderGQL KIND_UNION = "UNION"
  renderGQL KIND_INPUT_UNION = "INPUT_OBJECT"
  renderGQL KIND_LIST = "LIST"
  renderGQL KIND_NON_NULL = "NON_NULL"
  renderGQL KIND_INTERFACE = "INTERFACE"

--  Definitions:
--     Strictness:
--        Strict: Value (Strict) Types.
--             members: {scalar, enum , input}
--        Lazy: Resolver (lazy) Types
--             members: strict + {object, interface, union}
class Strictness t where
  isResolverType :: t -> Bool

instance Strictness TypeKind where
  isResolverType (KIND_OBJECT _) = True
  isResolverType KIND_UNION = True
  isResolverType KIND_INTERFACE = True
  isResolverType _ = False

-- TypeWrappers
-----------------------------------------------------------------------------------
data TypeWrapper
  = TypeList
      !TypeWrapper
      !Bool -- isRequired
  | BaseType
      !Bool -- isRequired
  deriving (Show, Eq, Lift)

mkBaseType :: TypeWrapper
mkBaseType = BaseType True

mkMaybeType :: TypeWrapper
mkMaybeType = BaseType False

-- If S is a subtype of T, "S <: T"
-- A is a subtype of B, then all terms of type A also have type B.
-- type B = Int | Null
-- type A = Int
-- A <: B
--
-- interface A { a: String }
--
-- type B implements A { a: String!}
--
-- type B is subtype of A since :  {String} ⊂ {String, null}
--
-- interface A { a: String! }
--
-- type B implements A { a: String }
--
-- type B is not subtype of A since :  {String, null} ⊂ {String}
--
-- type A = { T, Null}
-- type B = T
-- type B is subtype of A since :  {T} ⊂ {T, Null}
-- type B is Subtype if B since: {T} ⊂ {T}
class Subtyping t where
  isSubtype :: t -> t -> Bool

instance Subtyping TypeWrapper where
  isSubtype (TypeList b nonNull1) (TypeList a nonNull2) =
    nonNull1 >= nonNull2 && isSubtype b a
  isSubtype (BaseType b) (BaseType a) = b >= a
  isSubtype b a = b == a

-- TypeRef
-------------------------------------------------------------------
data TypeRef = TypeRef
  { typeConName :: TypeName,
    typeWrappers :: TypeWrapper
  }
  deriving (Show, Eq, Lift)

mkTypeRef :: TypeName -> TypeRef
mkTypeRef typeConName = TypeRef {typeConName, typeWrappers = mkBaseType}

instance Subtyping TypeRef where
  isSubtype t1 t2 =
    typeConName t1
      == typeConName t2
      && typeWrappers t1
      `isSubtype` typeWrappers t2

instance RenderGQL TypeRef where
  renderGQL TypeRef {typeConName, typeWrappers} = renderWrapper typeWrappers
    where
      renderWrapper (TypeList xs isNonNull) = "[" <> renderWrapper xs <> "]" <> renderNonNull isNonNull
      renderWrapper (BaseType isNonNull) = renderGQL typeConName <> renderNonNull isNonNull

renderNonNull :: Bool -> Rendering
renderNonNull True = "!"
renderNonNull False = ""

instance Msg TypeRef where
  msg = msg . packName . LT.toStrict . decodeUtf8 . render

class Nullable a where
  isNullable :: a -> Bool
  toNullable :: a -> a

instance Nullable TypeWrapper where
  isNullable (TypeList _ nonNull) = not nonNull
  isNullable (BaseType nonNull) = not nonNull
  toNullable (TypeList t _) = TypeList t False
  toNullable BaseType {} = BaseType False

instance Nullable TypeRef where
  isNullable = isNullable . typeWrappers
  toNullable TypeRef {..} = TypeRef {typeWrappers = toNullable typeWrappers, ..}