content: {-# 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, ..}
  