{-# 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,
)
data TypeKind
= KindScalar
| KindObject (Maybe OperationType)
| KindUnion
| KindEnum
| KindInputObject
| KindList
| KindNonNull
| KindInputUnion
| KindInterface
deriving (TypeKind -> TypeKind -> Bool
(TypeKind -> TypeKind -> Bool)
-> (TypeKind -> TypeKind -> Bool) -> Eq TypeKind
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
(Int -> TypeKind -> ShowS)
-> (TypeKind -> String) -> ([TypeKind] -> ShowS) -> Show TypeKind
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, TypeKind -> Q Exp
TypeKind -> Q (TExp TypeKind)
(TypeKind -> Q Exp)
-> (TypeKind -> Q (TExp TypeKind)) -> Lift TypeKind
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: TypeKind -> Q (TExp TypeKind)
$cliftTyped :: TypeKind -> Q (TExp TypeKind)
lift :: TypeKind -> Q Exp
$clift :: TypeKind -> Q Exp
Lift)
instance RenderGQL TypeKind where
renderGQL :: TypeKind -> Rendering
renderGQL TypeKind
KindScalar = Rendering
"SCALAR"
renderGQL KindObject {} = Rendering
"OBJECT"
renderGQL TypeKind
KindUnion = Rendering
"UNION"
renderGQL TypeKind
KindInputUnion = Rendering
"INPUT_OBJECT"
renderGQL TypeKind
KindEnum = Rendering
"ENUM"
renderGQL TypeKind
KindInputObject = Rendering
"INPUT_OBJECT"
renderGQL TypeKind
KindList = Rendering
"LIST"
renderGQL TypeKind
KindNonNull = Rendering
"NON_NULL"
renderGQL TypeKind
KindInterface = Rendering
"INTERFACE"
class Strictness t where
isResolverType :: t -> Bool
instance Strictness TypeKind where
isResolverType :: TypeKind -> Bool
isResolverType (KindObject Maybe OperationType
_) = Bool
True
isResolverType TypeKind
KindUnion = Bool
True
isResolverType TypeKind
KindInterface = Bool
True
isResolverType TypeKind
_ = Bool
False
data TypeWrapper
= TypeList !TypeWrapper !Bool
| BaseType !Bool
deriving (Int -> TypeWrapper -> ShowS
[TypeWrapper] -> ShowS
TypeWrapper -> String
(Int -> TypeWrapper -> ShowS)
-> (TypeWrapper -> String)
-> ([TypeWrapper] -> ShowS)
-> Show TypeWrapper
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
(TypeWrapper -> TypeWrapper -> Bool)
-> (TypeWrapper -> TypeWrapper -> Bool) -> Eq TypeWrapper
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, TypeWrapper -> Q Exp
TypeWrapper -> Q (TExp TypeWrapper)
(TypeWrapper -> Q Exp)
-> (TypeWrapper -> Q (TExp TypeWrapper)) -> Lift TypeWrapper
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: TypeWrapper -> Q (TExp TypeWrapper)
$cliftTyped :: TypeWrapper -> Q (TExp TypeWrapper)
lift :: TypeWrapper -> Q Exp
$clift :: TypeWrapper -> Q Exp
Lift)
mkBaseType :: TypeWrapper
mkBaseType :: TypeWrapper
mkBaseType = Bool -> TypeWrapper
BaseType Bool
True
mkMaybeType :: TypeWrapper
mkMaybeType :: TypeWrapper
mkMaybeType = Bool -> TypeWrapper
BaseType Bool
False
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 Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
>= Bool
nonNull2 Bool -> Bool -> Bool
&& TypeWrapper -> TypeWrapper -> Bool
forall t. Subtyping t => t -> t -> Bool
isSubtype TypeWrapper
b TypeWrapper
a
isSubtype (BaseType Bool
b) (BaseType Bool
a) = Bool
b Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
>= Bool
a
isSubtype TypeWrapper
b TypeWrapper
a = TypeWrapper
b TypeWrapper -> TypeWrapper -> Bool
forall a. Eq a => a -> a -> Bool
== TypeWrapper
a
data TypeRef = TypeRef
{ TypeRef -> TypeName
typeConName :: TypeName,
TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
}
deriving (Int -> TypeRef -> ShowS
[TypeRef] -> ShowS
TypeRef -> String
(Int -> TypeRef -> ShowS)
-> (TypeRef -> String) -> ([TypeRef] -> ShowS) -> Show TypeRef
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
(TypeRef -> TypeRef -> Bool)
-> (TypeRef -> TypeRef -> Bool) -> Eq TypeRef
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, TypeRef -> Q Exp
TypeRef -> Q (TExp TypeRef)
(TypeRef -> Q Exp) -> (TypeRef -> Q (TExp TypeRef)) -> Lift TypeRef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: TypeRef -> Q (TExp TypeRef)
$cliftTyped :: TypeRef -> Q (TExp TypeRef)
lift :: TypeRef -> Q Exp
$clift :: TypeRef -> Q Exp
Lift)
mkTypeRef :: TypeName -> TypeRef
mkTypeRef :: TypeName -> TypeRef
mkTypeRef TypeName
typeConName = TypeRef :: TypeName -> TypeWrapper -> TypeRef
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 TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRef -> TypeName
typeConName TypeRef
t2
Bool -> Bool -> Bool
&& TypeRef -> TypeWrapper
typeWrappers TypeRef
t1 TypeWrapper -> TypeWrapper -> Bool
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
"[" Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeWrapper -> Rendering
renderWrapper TypeWrapper
xs Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
"]" Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Bool -> Rendering
renderNonNull Bool
isNonNull
renderWrapper (BaseType Bool
isNonNull) = TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL TypeName
typeConName Rendering -> Rendering -> Rendering
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 = Name Any -> GQLError
forall a. Msg a => a -> GQLError
msg (Name Any -> GQLError)
-> (TypeRef -> Name Any) -> TypeRef -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Name Any
forall a (t :: NAME). NamePacking a => a -> Name t
packName (Text -> Name Any) -> (TypeRef -> Text) -> TypeRef -> Name Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.toStrict (Text -> Text) -> (TypeRef -> Text) -> TypeRef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (TypeRef -> ByteString) -> TypeRef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRef -> ByteString
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 = TypeWrapper -> Bool
forall a. Nullable a => a -> Bool
isNullable (TypeWrapper -> Bool)
-> (TypeRef -> TypeWrapper) -> TypeRef -> Bool
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 :: TypeName -> TypeWrapper -> TypeRef
TypeRef {typeWrappers :: TypeWrapper
typeWrappers = TypeWrapper -> TypeWrapper
forall a. Nullable a => a -> a
toNullable TypeWrapper
typeWrappers, TypeName
typeConName :: TypeName
typeConName :: TypeName
..}