{-# 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 (TypeKind -> TypeKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeKind -> TypeKind -> Bool
$c/= :: TypeKind -> TypeKind -> Bool
== :: TypeKind -> TypeKind -> Bool
$c== :: TypeKind -> TypeKind -> Bool
Eq, Int -> TypeKind -> ShowS
[TypeKind] -> ShowS
TypeKind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeKind] -> ShowS
$cshowList :: [TypeKind] -> ShowS
show :: TypeKind -> String
$cshow :: TypeKind -> String
showsPrec :: Int -> TypeKind -> ShowS
$cshowsPrec :: Int -> TypeKind -> ShowS
Show, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => TypeKind -> m Exp
forall (m :: * -> *). Quote m => TypeKind -> Code m TypeKind
liftTyped :: forall (m :: * -> *). Quote m => TypeKind -> Code m TypeKind
$cliftTyped :: forall (m :: * -> *). Quote m => TypeKind -> Code m TypeKind
lift :: forall (m :: * -> *). Quote m => TypeKind -> m Exp
$clift :: forall (m :: * -> *). Quote m => TypeKind -> m Exp
Lift)

instance RenderGQL TypeKind where
  renderGQL :: TypeKind -> Rendering
renderGQL TypeKind
KIND_SCALAR = Rendering
"SCALAR"
  renderGQL TypeKind
KIND_ENUM = Rendering
"ENUM"
  renderGQL KIND_OBJECT {} = Rendering
"OBJECT"
  renderGQL TypeKind
KIND_INPUT_OBJECT = Rendering
"INPUT_OBJECT"
  renderGQL TypeKind
KIND_UNION = Rendering
"UNION"
  renderGQL TypeKind
KIND_INPUT_UNION = Rendering
"INPUT_OBJECT"
  renderGQL TypeKind
KIND_LIST = Rendering
"LIST"
  renderGQL TypeKind
KIND_NON_NULL = Rendering
"NON_NULL"
  renderGQL TypeKind
KIND_INTERFACE = Rendering
"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 :: TypeKind -> Bool
isResolverType (KIND_OBJECT Maybe OperationType
_) = Bool
True
  isResolverType TypeKind
KIND_UNION = Bool
True
  isResolverType TypeKind
KIND_INTERFACE = Bool
True
  isResolverType TypeKind
_ = Bool
False

-- TypeWrappers
-----------------------------------------------------------------------------------
data TypeWrapper
  = TypeList
      !TypeWrapper
      !Bool -- isRequired
  | BaseType
      !Bool -- isRequired
  deriving (Int -> TypeWrapper -> ShowS
[TypeWrapper] -> ShowS
TypeWrapper -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeWrapper] -> ShowS
$cshowList :: [TypeWrapper] -> ShowS
show :: TypeWrapper -> String
$cshow :: TypeWrapper -> String
showsPrec :: Int -> TypeWrapper -> ShowS
$cshowsPrec :: Int -> TypeWrapper -> ShowS
Show, TypeWrapper -> TypeWrapper -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeWrapper -> TypeWrapper -> Bool
$c/= :: TypeWrapper -> TypeWrapper -> Bool
== :: TypeWrapper -> TypeWrapper -> Bool
$c== :: TypeWrapper -> TypeWrapper -> Bool
Eq, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => TypeWrapper -> m Exp
forall (m :: * -> *). Quote m => TypeWrapper -> Code m TypeWrapper
liftTyped :: forall (m :: * -> *). Quote m => TypeWrapper -> Code m TypeWrapper
$cliftTyped :: forall (m :: * -> *). Quote m => TypeWrapper -> Code m TypeWrapper
lift :: forall (m :: * -> *). Quote m => TypeWrapper -> m Exp
$clift :: forall (m :: * -> *). Quote m => TypeWrapper -> m Exp
Lift)

mkBaseType :: TypeWrapper
mkBaseType :: TypeWrapper
mkBaseType = Bool -> TypeWrapper
BaseType Bool
True

mkMaybeType :: TypeWrapper
mkMaybeType :: TypeWrapper
mkMaybeType = Bool -> TypeWrapper
BaseType Bool
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 :: TypeWrapper -> TypeWrapper -> Bool
isSubtype (TypeList TypeWrapper
b Bool
nonNull1) (TypeList TypeWrapper
a Bool
nonNull2) =
    Bool
nonNull1 forall a. Ord a => a -> a -> Bool
>= Bool
nonNull2 Bool -> Bool -> Bool
&& forall t. Subtyping t => t -> t -> Bool
isSubtype TypeWrapper
b TypeWrapper
a
  isSubtype (BaseType Bool
b) (BaseType Bool
a) = Bool
b forall a. Ord a => a -> a -> Bool
>= Bool
a
  isSubtype TypeWrapper
b TypeWrapper
a = TypeWrapper
b forall a. Eq a => a -> a -> Bool
== TypeWrapper
a

-- TypeRef
-------------------------------------------------------------------
data TypeRef = TypeRef
  { TypeRef -> TypeName
typeConName :: TypeName,
    TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
  }
  deriving (Int -> TypeRef -> ShowS
[TypeRef] -> ShowS
TypeRef -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeRef] -> ShowS
$cshowList :: [TypeRef] -> ShowS
show :: TypeRef -> String
$cshow :: TypeRef -> String
showsPrec :: Int -> TypeRef -> ShowS
$cshowsPrec :: Int -> TypeRef -> ShowS
Show, TypeRef -> TypeRef -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeRef -> TypeRef -> Bool
$c/= :: TypeRef -> TypeRef -> Bool
== :: TypeRef -> TypeRef -> Bool
$c== :: TypeRef -> TypeRef -> Bool
Eq, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => TypeRef -> m Exp
forall (m :: * -> *). Quote m => TypeRef -> Code m TypeRef
liftTyped :: forall (m :: * -> *). Quote m => TypeRef -> Code m TypeRef
$cliftTyped :: forall (m :: * -> *). Quote m => TypeRef -> Code m TypeRef
lift :: forall (m :: * -> *). Quote m => TypeRef -> m Exp
$clift :: forall (m :: * -> *). Quote m => TypeRef -> m Exp
Lift)

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

instance Subtyping TypeRef where
  isSubtype :: TypeRef -> TypeRef -> Bool
isSubtype TypeRef
t1 TypeRef
t2 =
    TypeRef -> TypeName
typeConName TypeRef
t1
      forall a. Eq a => a -> a -> Bool
== TypeRef -> TypeName
typeConName TypeRef
t2
      Bool -> Bool -> Bool
&& TypeRef -> TypeWrapper
typeWrappers TypeRef
t1
      forall t. Subtyping t => t -> t -> Bool
`isSubtype` TypeRef -> TypeWrapper
typeWrappers TypeRef
t2

instance RenderGQL TypeRef where
  renderGQL :: TypeRef -> Rendering
renderGQL TypeRef {TypeName
typeConName :: TypeName
typeConName :: TypeRef -> TypeName
typeConName, TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers} = TypeWrapper -> Rendering
renderWrapper TypeWrapper
typeWrappers
    where
      renderWrapper :: TypeWrapper -> Rendering
renderWrapper (TypeList TypeWrapper
xs Bool
isNonNull) = Rendering
"[" forall a. Semigroup a => a -> a -> a
<> TypeWrapper -> Rendering
renderWrapper TypeWrapper
xs forall a. Semigroup a => a -> a -> a
<> Rendering
"]" forall a. Semigroup a => a -> a -> a
<> Bool -> Rendering
renderNonNull Bool
isNonNull
      renderWrapper (BaseType Bool
isNonNull) = forall a. RenderGQL a => a -> Rendering
renderGQL TypeName
typeConName forall a. Semigroup a => a -> a -> a
<> Bool -> Rendering
renderNonNull Bool
isNonNull

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

instance Msg TypeRef where
  msg :: TypeRef -> GQLError
msg = forall a. Msg a => a -> GQLError
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => a -> Name t
packName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RenderGQL a => a -> ByteString
render

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

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

instance Nullable TypeRef where
  isNullable :: TypeRef -> Bool
isNullable = forall a. Nullable a => a -> Bool
isNullable forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRef -> TypeWrapper
typeWrappers
  toNullable :: TypeRef -> TypeRef
toNullable TypeRef {TypeName
TypeWrapper
typeWrappers :: TypeWrapper
typeConName :: TypeName
typeWrappers :: TypeRef -> TypeWrapper
typeConName :: TypeRef -> TypeName
..} = TypeRef {typeWrappers :: TypeWrapper
typeWrappers = forall a. Nullable a => a -> a
toNullable TypeWrapper
typeWrappers, TypeName
typeConName :: TypeName
typeConName :: TypeName
..}