{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Deriving.Schema.Internal
( KindedProxy (..),
KindedType (..),
builder,
inputType,
outputType,
setProxyType,
unpackMs,
UpdateDef (..),
withObject,
TyContentM,
asObjectType,
fromSchema,
updateByContent,
)
where
import Control.Applicative (Applicative (..))
import Control.Monad.Fail (fail)
import Data.Foldable (concatMap, traverse_)
import Data.Functor (($>), (<$>), Functor (..))
import Data.List (partition)
import qualified Data.Map as M
import Data.Maybe (Maybe (..), fromMaybe)
import Data.Morpheus.Error (globalErrorMessage)
import Data.Morpheus.Internal.Utils
( Failure (..),
empty,
singleton,
)
import Data.Morpheus.Server.Deriving.Utils
( ConsRep (..),
FieldRep (..),
ResRep (..),
fieldTypeName,
isEmptyConstraint,
isUnionRef,
)
import Data.Morpheus.Server.Types.GQLType
( GQLType (..),
TypeData (..),
)
import Data.Morpheus.Server.Types.SchemaT
( SchemaT,
insertType,
updateSchema,
)
import Data.Morpheus.Types.Internal.AST
( CONST,
DataEnumValue (..),
DataFingerprint (..),
DataUnion,
Description,
Directives,
ELEM,
FieldContent (..),
FieldDefinition (..),
FieldName,
FieldName (..),
FieldsDefinition,
IN,
LEAF,
OBJECT,
OUT,
Schema (..),
TRUE,
Token,
TypeCategory,
TypeContent (..),
TypeDefinition (..),
TypeName (..),
UnionMember (..),
VALID,
mkEnumContent,
mkField,
mkInputValue,
mkType,
mkUnionMember,
msg,
unsafeFromFields,
)
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
Result (..),
)
import Data.Proxy (Proxy (..))
import Data.Semigroup ((<>))
import Data.Traversable (traverse)
import Language.Haskell.TH (Exp, Q)
import Prelude
( ($),
(.),
Bool (..),
Show (..),
map,
null,
otherwise,
sequence,
)
data KindedProxy k a
= KindedProxy
data KindedType (cat :: TypeCategory) a where
InputType :: KindedType IN a
OutputType :: KindedType OUT a
inputType :: f a -> KindedType IN a
inputType _ = InputType
outputType :: f a -> KindedType OUT a
outputType _ = OutputType
deriving instance Show (KindedType cat a)
setProxyType :: f b -> kinded k a -> KindedProxy k b
setProxyType _ _ = KindedProxy
fromSchema :: Eventless (Schema VALID) -> Q Exp
fromSchema Success {} = [|()|]
fromSchema Failure {errors} = fail (show errors)
withObject :: (GQLType a) => KindedType c a -> TypeContent TRUE any s -> SchemaT (FieldsDefinition c s)
withObject InputType DataInputObject {inputObjectFields} = pure inputObjectFields
withObject OutputType DataObject {objectFields} = pure objectFields
withObject x _ = failureOnlyObject x
asObjectType ::
GQLType a =>
(f2 a -> SchemaT (FieldsDefinition OUT CONST)) ->
f2 a ->
SchemaT (TypeDefinition OBJECT CONST)
asObjectType f proxy = (`mkObjectType` gqlTypeName (__type proxy)) <$> f proxy
mkObjectType :: FieldsDefinition OUT CONST -> TypeName -> TypeDefinition OBJECT CONST
mkObjectType fields typeName = mkType typeName (DataObject [] fields)
failureOnlyObject :: forall c a b. (GQLType a) => KindedType c a -> SchemaT b
failureOnlyObject _ =
failure
$ globalErrorMessage
$ msg (gqlTypeName $ __type (Proxy @a)) <> " should have only one nonempty constructor"
type TyContentM kind = (SchemaT (Maybe (FieldContent TRUE kind CONST)))
type TyContent kind = Maybe (FieldContent TRUE kind CONST)
unpackM :: FieldRep (TyContentM k) -> SchemaT (FieldRep (TyContent k))
unpackM FieldRep {..} =
FieldRep fieldSelector fieldTypeRef fieldIsObject
<$> fieldValue
unpackCons :: ConsRep (TyContentM k) -> SchemaT (ConsRep (TyContent k))
unpackCons ConsRep {..} = ConsRep consName <$> traverse unpackM consFields
unpackMs :: [ConsRep (TyContentM k)] -> SchemaT [ConsRep (TyContent k)]
unpackMs = traverse unpackCons
builder ::
forall kind (a :: *).
GQLType a =>
KindedType kind a ->
[ConsRep (TyContent kind)] ->
SchemaT (TypeContent TRUE kind CONST)
builder scope [ConsRep {consFields}] = buildObj <$> sequence (implements (Proxy @a))
where
buildObj interfaces = wrapFields interfaces scope (mkFieldsDefinition consFields)
builder scope cons = genericUnion scope cons
where
proxy = Proxy @a
typeData = __type proxy
genericUnion InputType = buildInputUnion typeData
genericUnion OutputType = buildUnionType typeData DataUnion (DataObject [])
class UpdateDef value where
updateDef :: GQLType a => f a -> value -> value
instance UpdateDef (TypeContent TRUE c CONST) where
updateDef proxy DataObject {objectFields = fields, ..} =
DataObject {objectFields = fmap (updateDef proxy) fields, ..}
updateDef proxy DataInputObject {inputObjectFields = fields} =
DataInputObject {inputObjectFields = fmap (updateDef proxy) fields, ..}
updateDef proxy DataInterface {interfaceFields = fields} =
DataInterface {interfaceFields = fmap (updateDef proxy) fields, ..}
updateDef proxy (DataEnum enums) = DataEnum $ fmap (updateDef proxy) enums
updateDef _ x = x
instance GetFieldContent cat => UpdateDef (FieldDefinition cat CONST) where
updateDef proxy FieldDefinition {fieldName, fieldType, fieldContent} =
FieldDefinition
{ fieldName,
fieldDescription = lookupDescription (readName fieldName) proxy,
fieldDirectives = lookupDirectives (readName fieldName) proxy,
fieldContent = getFieldContent fieldName fieldContent proxy,
..
}
instance UpdateDef (DataEnumValue CONST) where
updateDef proxy DataEnumValue {enumName} =
DataEnumValue
{ enumName,
enumDescription = lookupDescription (readTypeName enumName) proxy,
enumDirectives = lookupDirectives (readTypeName enumName) proxy
}
lookupDescription :: GQLType a => Token -> f a -> Maybe Description
lookupDescription name = (name `M.lookup`) . getDescriptions
lookupDirectives :: GQLType a => Token -> f a -> Directives CONST
lookupDirectives name = fromMaybe [] . (name `M.lookup`) . getDirectives
class GetFieldContent c where
getFieldContent :: GQLType a => FieldName -> Maybe (FieldContent TRUE c CONST) -> f a -> Maybe (FieldContent TRUE c CONST)
instance GetFieldContent IN where
getFieldContent name val proxy =
case name `M.lookup` getFieldContents proxy of
Just (Just x, _) -> Just (DefaultInputValue x)
_ -> val
instance GetFieldContent OUT where
getFieldContent name args proxy =
case name `M.lookup` getFieldContents proxy of
Just (_, Just x) -> Just (FieldArgs x)
_ -> args
updateByContent ::
GQLType a =>
(f kind a -> SchemaT (TypeContent TRUE cat CONST)) ->
f kind a ->
SchemaT ()
updateByContent f proxy =
updateSchema
(gqlTypeName $ __type proxy)
(gqlFingerprint $ __type proxy)
deriveD
proxy
where
deriveD _ = buildType proxy <$> f proxy
analyseRep :: TypeName -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> ResRep (Maybe (FieldContent TRUE kind CONST))
analyseRep baseName cons =
ResRep
{ enumCons = fmap consName enumRep,
unionRef = fieldTypeName <$> concatMap consFields unionRefRep,
unionRecordRep
}
where
(enumRep, left1) = partition isEmptyConstraint cons
(unionRefRep, unionRecordRep) = partition (isUnionRef baseName) left1
buildInputUnion ::
TypeData ->
[ConsRep (Maybe (FieldContent TRUE IN CONST))] ->
SchemaT (TypeContent TRUE IN CONST)
buildInputUnion TypeData {gqlTypeName, gqlFingerprint} =
mkInputUnionType gqlFingerprint . analyseRep gqlTypeName
buildUnionType ::
(ELEM LEAF kind ~ TRUE) =>
TypeData ->
(DataUnion CONST -> TypeContent TRUE kind CONST) ->
(FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->
[ConsRep (Maybe (FieldContent TRUE kind CONST))] ->
SchemaT (TypeContent TRUE kind CONST)
buildUnionType typeData wrapUnion wrapObject =
mkUnionType typeData wrapUnion wrapObject . analyseRep (gqlTypeName typeData)
mkInputUnionType :: DataFingerprint -> ResRep (Maybe (FieldContent TRUE IN CONST)) -> SchemaT (TypeContent TRUE IN CONST)
mkInputUnionType _ ResRep {unionRef = [], unionRecordRep = [], enumCons} = pure $ mkEnumContent enumCons
mkInputUnionType baseFingerprint ResRep {unionRef, unionRecordRep, enumCons} = DataInputUnion <$> typeMembers
where
typeMembers :: SchemaT [UnionMember IN CONST]
typeMembers = withMembers <$> buildUnions wrapInputObject baseFingerprint unionRecordRep
where
withMembers unionMembers = fmap mkUnionMember (unionRef <> unionMembers) <> fmap (`UnionMember` False) enumCons
wrapInputObject :: (FieldsDefinition IN CONST -> TypeContent TRUE IN CONST)
wrapInputObject = DataInputObject
mkUnionType ::
(ELEM LEAF kind ~ TRUE) =>
TypeData ->
(DataUnion CONST -> TypeContent TRUE kind CONST) ->
(FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->
ResRep (Maybe (FieldContent TRUE kind CONST)) ->
SchemaT (TypeContent TRUE kind CONST)
mkUnionType _ _ _ ResRep {unionRef = [], unionRecordRep = [], enumCons} = pure $ mkEnumContent enumCons
mkUnionType typeData@TypeData {gqlFingerprint} wrapUnion wrapObject ResRep {unionRef, unionRecordRep, enumCons} = wrapUnion . map mkUnionMember <$> typeMembers
where
typeMembers = do
enums <- buildUnionEnum wrapObject typeData enumCons
unions <- buildUnions wrapObject gqlFingerprint unionRecordRep
pure (unionRef <> enums <> unions)
wrapFields :: [TypeName] -> KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
wrapFields _ InputType = DataInputObject
wrapFields interfaces OutputType = DataObject interfaces
mkFieldsDefinition :: [FieldRep (Maybe (FieldContent TRUE kind CONST))] -> FieldsDefinition kind CONST
mkFieldsDefinition = unsafeFromFields . fmap fieldByRep
fieldByRep :: FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST
fieldByRep FieldRep {fieldSelector, fieldTypeRef, fieldValue} =
mkField fieldValue fieldSelector fieldTypeRef
buildUnions ::
(FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->
DataFingerprint ->
[ConsRep (Maybe (FieldContent TRUE kind CONST))] ->
SchemaT [TypeName]
buildUnions wrapObject baseFingerprint cons =
traverse_ buildURecType cons $> fmap consName cons
where
buildURecType = insertType . buildUnionRecord wrapObject baseFingerprint
buildUnionEnum ::
(FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->
TypeData ->
[TypeName] ->
SchemaT [TypeName]
buildUnionEnum wrapObject TypeData {gqlTypeName, gqlFingerprint} enums = updates $> members
where
members
| null enums = []
| otherwise = [enumTypeWrapperName]
enumTypeName = gqlTypeName <> "Enum"
enumTypeWrapperName = enumTypeName <> "Object"
updates :: SchemaT ()
updates
| null enums = pure ()
| otherwise =
buildEnumObject wrapObject enumTypeWrapperName gqlFingerprint enumTypeName
*> buildEnum enumTypeName gqlFingerprint enums
buildType :: GQLType a => f a -> TypeContent TRUE cat CONST -> TypeDefinition cat CONST
buildType proxy typeContent =
TypeDefinition
{ typeName = gqlTypeName typeData,
typeFingerprint = gqlFingerprint typeData,
typeDescription = description proxy,
typeDirectives = [],
typeContent
}
where
typeData = __type proxy
buildUnionRecord ::
(FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->
DataFingerprint ->
ConsRep (Maybe (FieldContent TRUE kind CONST)) ->
TypeDefinition kind CONST
buildUnionRecord wrapObject typeFingerprint ConsRep {consName, consFields} =
mkSubType consName typeFingerprint (wrapObject $ mkFieldsDefinition consFields)
buildEnum :: TypeName -> DataFingerprint -> [TypeName] -> SchemaT ()
buildEnum typeName typeFingerprint tags =
insertType
( mkSubType typeName typeFingerprint (mkEnumContent tags) ::
TypeDefinition LEAF CONST
)
buildEnumObject ::
(FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->
TypeName ->
DataFingerprint ->
TypeName ->
SchemaT ()
buildEnumObject wrapObject typeName typeFingerprint enumTypeName =
insertType $
mkSubType
typeName
typeFingerprint
( wrapObject
$ singleton
$ mkInputValue "enum" [] enumTypeName
)
mkSubType :: TypeName -> DataFingerprint -> TypeContent TRUE k CONST -> TypeDefinition k CONST
mkSubType typeName typeFingerprint typeContent =
TypeDefinition
{ typeName,
typeFingerprint,
typeDescription = Nothing,
typeDirectives = empty,
typeContent
}