{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    updateSchema,
    insertType,
    TypeFingerprint (..),
    toSchema,
    withInput,
    extendImplements,
  )
where

import Control.Monad.Except (MonadError (..))
import qualified Data.Map as Map
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    CONST,
    GQLError,
    IN,
    OBJECT,
    OUT,
    Schema (..),
    TypeCategory (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    defineSchemaWith,
    msg,
    toAny,
  )
import GHC.Fingerprint.Type (Fingerprint)
import Relude hiding (empty)

data TypeFingerprint
  = TypeableFingerprint TypeCategory [Fingerprint]
  | InternalFingerprint TypeName
  | CustomFingerprint TypeName
  deriving
    ( (forall x. TypeFingerprint -> Rep TypeFingerprint x)
-> (forall x. Rep TypeFingerprint x -> TypeFingerprint)
-> Generic TypeFingerprint
forall x. Rep TypeFingerprint x -> TypeFingerprint
forall x. TypeFingerprint -> Rep TypeFingerprint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TypeFingerprint x -> TypeFingerprint
$cfrom :: forall x. TypeFingerprint -> Rep TypeFingerprint x
Generic,
      Int -> TypeFingerprint -> ShowS
[TypeFingerprint] -> ShowS
TypeFingerprint -> String
(Int -> TypeFingerprint -> ShowS)
-> (TypeFingerprint -> String)
-> ([TypeFingerprint] -> ShowS)
-> Show TypeFingerprint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeFingerprint] -> ShowS
$cshowList :: [TypeFingerprint] -> ShowS
show :: TypeFingerprint -> String
$cshow :: TypeFingerprint -> String
showsPrec :: Int -> TypeFingerprint -> ShowS
$cshowsPrec :: Int -> TypeFingerprint -> ShowS
Show,
      TypeFingerprint -> TypeFingerprint -> Bool
(TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> Eq TypeFingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeFingerprint -> TypeFingerprint -> Bool
$c/= :: TypeFingerprint -> TypeFingerprint -> Bool
== :: TypeFingerprint -> TypeFingerprint -> Bool
$c== :: TypeFingerprint -> TypeFingerprint -> Bool
Eq,
      Eq TypeFingerprint
Eq TypeFingerprint
-> (TypeFingerprint -> TypeFingerprint -> Ordering)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> TypeFingerprint)
-> (TypeFingerprint -> TypeFingerprint -> TypeFingerprint)
-> Ord TypeFingerprint
TypeFingerprint -> TypeFingerprint -> Bool
TypeFingerprint -> TypeFingerprint -> Ordering
TypeFingerprint -> TypeFingerprint -> TypeFingerprint
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TypeFingerprint -> TypeFingerprint -> TypeFingerprint
$cmin :: TypeFingerprint -> TypeFingerprint -> TypeFingerprint
max :: TypeFingerprint -> TypeFingerprint -> TypeFingerprint
$cmax :: TypeFingerprint -> TypeFingerprint -> TypeFingerprint
>= :: TypeFingerprint -> TypeFingerprint -> Bool
$c>= :: TypeFingerprint -> TypeFingerprint -> Bool
> :: TypeFingerprint -> TypeFingerprint -> Bool
$c> :: TypeFingerprint -> TypeFingerprint -> Bool
<= :: TypeFingerprint -> TypeFingerprint -> Bool
$c<= :: TypeFingerprint -> TypeFingerprint -> Bool
< :: TypeFingerprint -> TypeFingerprint -> Bool
$c< :: TypeFingerprint -> TypeFingerprint -> Bool
compare :: TypeFingerprint -> TypeFingerprint -> Ordering
$ccompare :: TypeFingerprint -> TypeFingerprint -> Ordering
$cp1Ord :: Eq TypeFingerprint
Ord
    )

type MyMap = (Map TypeFingerprint (TypeDefinition ANY CONST), Map TypeName [TypeName])

-- Helper Functions
newtype SchemaT (cat :: TypeCategory) a = SchemaT
  { SchemaT cat a -> GQLResult (a, [MyMap -> GQLResult MyMap])
runSchemaT ::
      GQLResult
        ( a,
          [MyMap -> GQLResult MyMap]
        )
  }
  deriving (a -> SchemaT cat b -> SchemaT cat a
(a -> b) -> SchemaT cat a -> SchemaT cat b
(forall a b. (a -> b) -> SchemaT cat a -> SchemaT cat b)
-> (forall a b. a -> SchemaT cat b -> SchemaT cat a)
-> Functor (SchemaT cat)
forall a b. a -> SchemaT cat b -> SchemaT cat a
forall a b. (a -> b) -> SchemaT cat a -> SchemaT cat b
forall (cat :: TypeCategory) a b.
a -> SchemaT cat b -> SchemaT cat a
forall (cat :: TypeCategory) a b.
(a -> b) -> SchemaT cat a -> SchemaT cat b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SchemaT cat b -> SchemaT cat a
$c<$ :: forall (cat :: TypeCategory) a b.
a -> SchemaT cat b -> SchemaT cat a
fmap :: (a -> b) -> SchemaT cat a -> SchemaT cat b
$cfmap :: forall (cat :: TypeCategory) a b.
(a -> b) -> SchemaT cat a -> SchemaT cat b
Functor)

instance MonadError GQLError (SchemaT c) where
  throwError :: GQLError -> SchemaT c a
throwError = GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT c a
forall (cat :: TypeCategory) a.
GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT cat a
SchemaT (GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT c a)
-> (GQLError -> GQLResult (a, [MyMap -> GQLResult MyMap]))
-> GQLError
-> SchemaT c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> GQLResult (a, [MyMap -> GQLResult MyMap])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: SchemaT c a -> (GQLError -> SchemaT c a) -> SchemaT c a
catchError (SchemaT GQLResult (a, [MyMap -> GQLResult MyMap])
mx) GQLError -> SchemaT c a
f = GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT c a
forall (cat :: TypeCategory) a.
GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT cat a
SchemaT (GQLResult (a, [MyMap -> GQLResult MyMap])
-> (GQLError -> GQLResult (a, [MyMap -> GQLResult MyMap]))
-> GQLResult (a, [MyMap -> GQLResult MyMap])
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError GQLResult (a, [MyMap -> GQLResult MyMap])
mx (SchemaT c a -> GQLResult (a, [MyMap -> GQLResult MyMap])
forall (cat :: TypeCategory) a.
SchemaT cat a -> GQLResult (a, [MyMap -> GQLResult MyMap])
runSchemaT (SchemaT c a -> GQLResult (a, [MyMap -> GQLResult MyMap]))
-> (GQLError -> SchemaT c a)
-> GQLError
-> GQLResult (a, [MyMap -> GQLResult MyMap])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> SchemaT c a
f))

instance Applicative (SchemaT c) where
  pure :: a -> SchemaT c a
pure = GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT c a
forall (cat :: TypeCategory) a.
GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT cat a
SchemaT (GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT c a)
-> (a -> GQLResult (a, [MyMap -> GQLResult MyMap]))
-> a
-> SchemaT c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [MyMap -> GQLResult MyMap])
-> GQLResult (a, [MyMap -> GQLResult MyMap])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, [MyMap -> GQLResult MyMap])
 -> GQLResult (a, [MyMap -> GQLResult MyMap]))
-> (a -> (a, [MyMap -> GQLResult MyMap]))
-> a
-> GQLResult (a, [MyMap -> GQLResult MyMap])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,[])
  (SchemaT GQLResult (a -> b, [MyMap -> GQLResult MyMap])
v1) <*> :: SchemaT c (a -> b) -> SchemaT c a -> SchemaT c b
<*> (SchemaT GQLResult (a, [MyMap -> GQLResult MyMap])
v2) = GQLResult (b, [MyMap -> GQLResult MyMap]) -> SchemaT c b
forall (cat :: TypeCategory) a.
GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT cat a
SchemaT (GQLResult (b, [MyMap -> GQLResult MyMap]) -> SchemaT c b)
-> GQLResult (b, [MyMap -> GQLResult MyMap]) -> SchemaT c b
forall a b. (a -> b) -> a -> b
$ do
    (a -> b
f, [MyMap -> GQLResult MyMap]
u1) <- GQLResult (a -> b, [MyMap -> GQLResult MyMap])
v1
    (a
a, [MyMap -> GQLResult MyMap]
u2) <- GQLResult (a, [MyMap -> GQLResult MyMap])
v2
    (b, [MyMap -> GQLResult MyMap])
-> GQLResult (b, [MyMap -> GQLResult MyMap])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
a, [MyMap -> GQLResult MyMap]
u1 [MyMap -> GQLResult MyMap]
-> [MyMap -> GQLResult MyMap] -> [MyMap -> GQLResult MyMap]
forall a. Semigroup a => a -> a -> a
<> [MyMap -> GQLResult MyMap]
u2)

instance Monad (SchemaT c) where
  return :: a -> SchemaT c a
return = a -> SchemaT c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (SchemaT GQLResult (a, [MyMap -> GQLResult MyMap])
v1) >>= :: SchemaT c a -> (a -> SchemaT c b) -> SchemaT c b
>>= a -> SchemaT c b
f =
    GQLResult (b, [MyMap -> GQLResult MyMap]) -> SchemaT c b
forall (cat :: TypeCategory) a.
GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT cat a
SchemaT (GQLResult (b, [MyMap -> GQLResult MyMap]) -> SchemaT c b)
-> GQLResult (b, [MyMap -> GQLResult MyMap]) -> SchemaT c b
forall a b. (a -> b) -> a -> b
$ do
      (a
x, [MyMap -> GQLResult MyMap]
up1) <- GQLResult (a, [MyMap -> GQLResult MyMap])
v1
      (b
y, [MyMap -> GQLResult MyMap]
up2) <- SchemaT c b -> GQLResult (b, [MyMap -> GQLResult MyMap])
forall (cat :: TypeCategory) a.
SchemaT cat a -> GQLResult (a, [MyMap -> GQLResult MyMap])
runSchemaT (a -> SchemaT c b
f a
x)
      (b, [MyMap -> GQLResult MyMap])
-> GQLResult (b, [MyMap -> GQLResult MyMap])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
y, [MyMap -> GQLResult MyMap]
up1 [MyMap -> GQLResult MyMap]
-> [MyMap -> GQLResult MyMap] -> [MyMap -> GQLResult MyMap]
forall a. Semigroup a => a -> a -> a
<> [MyMap -> GQLResult MyMap]
up2)

toSchema ::
  SchemaT
    c
    ( TypeDefinition OBJECT CONST,
      Maybe (TypeDefinition OBJECT CONST),
      Maybe (TypeDefinition OBJECT CONST)
    ) ->
  GQLResult (Schema CONST)
toSchema :: SchemaT
  c
  (TypeDefinition OBJECT CONST, Maybe (TypeDefinition OBJECT CONST),
   Maybe (TypeDefinition OBJECT CONST))
-> GQLResult (Schema CONST)
toSchema (SchemaT GQLResult
  ((TypeDefinition OBJECT CONST, Maybe (TypeDefinition OBJECT CONST),
    Maybe (TypeDefinition OBJECT CONST)),
   [MyMap -> GQLResult MyMap])
v) = do
  ((TypeDefinition OBJECT CONST
q, Maybe (TypeDefinition OBJECT CONST)
m, Maybe (TypeDefinition OBJECT CONST)
s), [MyMap -> GQLResult MyMap]
typeDefs) <- GQLResult
  ((TypeDefinition OBJECT CONST, Maybe (TypeDefinition OBJECT CONST),
    Maybe (TypeDefinition OBJECT CONST)),
   [MyMap -> GQLResult MyMap])
v
  (Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions, Map TypeName [TypeName]
implements) <- MyMap -> [MyMap -> GQLResult MyMap] -> GQLResult MyMap
forall (m :: * -> *) a. Monad m => a -> [a -> m a] -> m a
execUpdates (Map TypeFingerprint (TypeDefinition ANY CONST)
forall k a. Map k a
Map.empty, Map TypeName [TypeName]
forall k a. Map k a
Map.empty) [MyMap -> GQLResult MyMap]
typeDefs
  [TypeDefinition ANY CONST]
types <- (TypeDefinition ANY CONST -> TypeDefinition ANY CONST)
-> [TypeDefinition ANY CONST] -> [TypeDefinition ANY CONST]
forall a b. (a -> b) -> [a] -> [b]
map (Map TypeName [TypeName]
-> TypeDefinition ANY CONST -> TypeDefinition ANY CONST
forall (c :: TypeCategory).
Map TypeName [TypeName]
-> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements Map TypeName [TypeName]
implements) ([TypeDefinition ANY CONST] -> [TypeDefinition ANY CONST])
-> Result GQLError [TypeDefinition ANY CONST]
-> Result GQLError [TypeDefinition ANY CONST]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TypeFingerprint, TypeDefinition ANY CONST)]
-> Result GQLError [TypeDefinition ANY CONST]
forall (k :: TypeCategory) (a :: Stage).
[(TypeFingerprint, TypeDefinition k a)]
-> GQLResult [TypeDefinition k a]
checkTypeCollisions (Map TypeFingerprint (TypeDefinition ANY CONST)
-> [(TypeFingerprint, TypeDefinition ANY CONST)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions)
  [TypeDefinition ANY CONST]
-> (Maybe (TypeDefinition OBJECT CONST),
    Maybe (TypeDefinition OBJECT CONST),
    Maybe (TypeDefinition OBJECT CONST))
-> GQLResult (Schema CONST)
forall (f :: * -> *) (cat :: TypeCategory) (s :: Stage).
(Monad f, MonadError GQLError f) =>
[TypeDefinition cat s]
-> (Maybe (TypeDefinition OBJECT s),
    Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> f (Schema s)
defineSchemaWith [TypeDefinition ANY CONST]
types (TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST)
forall a. a -> Maybe a
Just TypeDefinition OBJECT CONST
q, Maybe (TypeDefinition OBJECT CONST)
m, Maybe (TypeDefinition OBJECT CONST)
s)

insertImplements :: Map TypeName [TypeName] -> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements :: Map TypeName [TypeName]
-> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements Map TypeName [TypeName]
x TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {[TypeName]
FieldsDefinition OUT CONST
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent OBJECT a s -> [TypeName]
objectFields :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT CONST
objectImplements :: [TypeName]
..}, Maybe Description
TypeName
Directives CONST
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeDirectives :: Directives CONST
typeName :: TypeName
typeDescription :: Maybe Description
..} =
  TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
    { typeContent :: TypeContent TRUE c CONST
typeContent =
        DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s
DataObject
          { objectImplements :: [TypeName]
objectImplements = [TypeName]
objectImplements [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
implements,
            FieldsDefinition OUT CONST
objectFields :: FieldsDefinition OUT CONST
objectFields :: FieldsDefinition OUT CONST
..
          },
      Maybe Description
TypeName
Directives CONST
typeDescription :: Maybe Description
typeName :: TypeName
typeDirectives :: Directives CONST
typeDirectives :: Directives CONST
typeName :: TypeName
typeDescription :: Maybe Description
..
    }
  where
    implements :: [TypeName]
    implements :: [TypeName]
implements = [TypeName] -> TypeName -> Map TypeName [TypeName] -> [TypeName]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] TypeName
typeName Map TypeName [TypeName]
x
insertImplements Map TypeName [TypeName]
_ TypeDefinition c CONST
t = TypeDefinition c CONST
t

withInput :: SchemaT IN a -> SchemaT OUT a
withInput :: SchemaT IN a -> SchemaT OUT a
withInput (SchemaT GQLResult (a, [MyMap -> GQLResult MyMap])
x) = GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT OUT a
forall (cat :: TypeCategory) a.
GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT cat a
SchemaT GQLResult (a, [MyMap -> GQLResult MyMap])
x

checkTypeCollisions :: [(TypeFingerprint, TypeDefinition k a)] -> GQLResult [TypeDefinition k a]
checkTypeCollisions :: [(TypeFingerprint, TypeDefinition k a)]
-> GQLResult [TypeDefinition k a]
checkTypeCollisions = (Map (TypeName, TypeFingerprint) (TypeDefinition k a)
 -> [TypeDefinition k a])
-> Result
     GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
-> GQLResult [TypeDefinition k a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> [TypeDefinition k a]
forall k a. Map k a -> [a]
Map.elems (Result
   GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
 -> GQLResult [TypeDefinition k a])
-> ([(TypeFingerprint, TypeDefinition k a)]
    -> Result
         GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a)))
-> [(TypeFingerprint, TypeDefinition k a)]
-> GQLResult [TypeDefinition k a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (TypeName, TypeFingerprint) (TypeDefinition k a)
 -> (TypeFingerprint, TypeDefinition k a)
 -> Result
      GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a)))
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> [(TypeFingerprint, TypeDefinition k a)]
-> Result
     GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> (TypeFingerprint, TypeDefinition k a)
-> Result
     GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall (k :: TypeCategory) (a :: Stage).
Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> (TypeFingerprint, TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
collectTypes Map (TypeName, TypeFingerprint) (TypeDefinition k a)
forall k a. Map k a
Map.empty
  where
    collectTypes :: Map (TypeName, TypeFingerprint) (TypeDefinition k a) -> (TypeFingerprint, TypeDefinition k a) -> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
    collectTypes :: Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> (TypeFingerprint, TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
collectTypes Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum (TypeFingerprint
fp, TypeDefinition k a
typ) = GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
-> (TypeDefinition k a
    -> GQLResult
         (Map (TypeName, TypeFingerprint) (TypeDefinition k a)))
-> Maybe (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
addType (TypeDefinition k a
-> TypeDefinition k a
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
handleCollision TypeDefinition k a
typ) ((TypeName, TypeFingerprint)
key (TypeName, TypeFingerprint)
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> Maybe (TypeDefinition k a)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum)
      where
        addType :: GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
addType = Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (TypeName, TypeFingerprint) (TypeDefinition k a)
 -> GQLResult
      (Map (TypeName, TypeFingerprint) (TypeDefinition k a)))
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall a b. (a -> b) -> a -> b
$ (TypeName, TypeFingerprint)
-> TypeDefinition k a
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TypeName, TypeFingerprint)
key TypeDefinition k a
typ Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum
        key :: (TypeName, TypeFingerprint)
key = (TypeDefinition k a -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition k a
typ, TypeFingerprint -> TypeFingerprint
withSameCategory TypeFingerprint
fp)
        handleCollision :: TypeDefinition k a
-> TypeDefinition k a
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
handleCollision t1 :: TypeDefinition k a
t1@TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataEnum {}} TypeDefinition k a
t2 | TypeDefinition k a
t1 TypeDefinition k a -> TypeDefinition k a -> Bool
forall a. Eq a => a -> a -> Bool
== TypeDefinition k a
t2 = Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum
        handleCollision TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataScalar {}} TypeDefinition {typeContent = DataScalar {}} = Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum
        handleCollision TypeDefinition {typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName = TypeName
name1} TypeDefinition k a
_ = TypeName
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall b. TypeName -> GQLResult b
failureRequirePrefix TypeName
name1

failureRequirePrefix :: TypeName -> GQLResult b
failureRequirePrefix :: TypeName -> GQLResult b
failureRequirePrefix TypeName
typename =
  GQLError -> GQLResult b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLResult b) -> GQLError -> GQLResult b
forall a b. (a -> b) -> a -> b
$
    GQLError
"It appears that the Haskell type "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
typename
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" was used as both input and output type, which is not allowed by GraphQL specifications."
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"\n\n "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"If you supply \"typeNameModifier\" in \"GQLType.typeOptions\", "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"you can override the default type names for "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
typename
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" to solve this problem."

withSameCategory :: TypeFingerprint -> TypeFingerprint
withSameCategory :: TypeFingerprint -> TypeFingerprint
withSameCategory (TypeableFingerprint TypeCategory
_ [Fingerprint]
xs) = TypeCategory -> [Fingerprint] -> TypeFingerprint
TypeableFingerprint TypeCategory
OUT [Fingerprint]
xs
withSameCategory TypeFingerprint
x = TypeFingerprint
x

execUpdates :: Monad m => a -> [a -> m a] -> m a
execUpdates :: a -> [a -> m a] -> m a
execUpdates = (a -> (a -> m a) -> m a) -> a -> [a -> m a] -> m a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM a -> (a -> m a) -> m a
forall a b. a -> (a -> b) -> b
(&)

insertType :: TypeDefinition cat CONST -> SchemaT cat' ()
insertType :: TypeDefinition cat CONST -> SchemaT cat' ()
insertType TypeDefinition cat CONST
dt = TypeFingerprint
-> (() -> SchemaT cat' (TypeDefinition cat CONST))
-> ()
-> SchemaT cat' ()
forall a (cat' :: TypeCategory) (cat :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (TypeDefinition cat CONST))
-> a
-> SchemaT cat' ()
updateSchema (TypeName -> TypeFingerprint
CustomFingerprint (TypeDefinition cat CONST -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition cat CONST
dt)) (SchemaT cat' (TypeDefinition cat CONST)
-> () -> SchemaT cat' (TypeDefinition cat CONST)
forall a b. a -> b -> a
const (SchemaT cat' (TypeDefinition cat CONST)
 -> () -> SchemaT cat' (TypeDefinition cat CONST))
-> SchemaT cat' (TypeDefinition cat CONST)
-> ()
-> SchemaT cat' (TypeDefinition cat CONST)
forall a b. (a -> b) -> a -> b
$ TypeDefinition cat CONST -> SchemaT cat' (TypeDefinition cat CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition cat CONST
dt) ()

updateSchema ::
  TypeFingerprint ->
  (a -> SchemaT cat' (TypeDefinition cat CONST)) ->
  a ->
  SchemaT cat' ()
updateSchema :: TypeFingerprint
-> (a -> SchemaT cat' (TypeDefinition cat CONST))
-> a
-> SchemaT cat' ()
updateSchema InternalFingerprint {} a -> SchemaT cat' (TypeDefinition cat CONST)
_ a
_ = GQLResult ((), [MyMap -> GQLResult MyMap]) -> SchemaT cat' ()
forall (cat :: TypeCategory) a.
GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT cat a
SchemaT (GQLResult ((), [MyMap -> GQLResult MyMap]) -> SchemaT cat' ())
-> GQLResult ((), [MyMap -> GQLResult MyMap]) -> SchemaT cat' ()
forall a b. (a -> b) -> a -> b
$ ((), [MyMap -> GQLResult MyMap])
-> GQLResult ((), [MyMap -> GQLResult MyMap])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [])
updateSchema TypeFingerprint
fingerprint a -> SchemaT cat' (TypeDefinition cat CONST)
f a
x =
  GQLResult ((), [MyMap -> GQLResult MyMap]) -> SchemaT cat' ()
forall (cat :: TypeCategory) a.
GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT cat a
SchemaT (GQLResult ((), [MyMap -> GQLResult MyMap]) -> SchemaT cat' ())
-> GQLResult ((), [MyMap -> GQLResult MyMap]) -> SchemaT cat' ()
forall a b. (a -> b) -> a -> b
$ ((), [MyMap -> GQLResult MyMap])
-> GQLResult ((), [MyMap -> GQLResult MyMap])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [MyMap -> GQLResult MyMap
upLib])
  where
    upLib :: MyMap -> GQLResult MyMap
    upLib :: MyMap -> GQLResult MyMap
upLib (Map TypeFingerprint (TypeDefinition ANY CONST)
lib, Map TypeName [TypeName]
conn)
      | TypeFingerprint
-> Map TypeFingerprint (TypeDefinition ANY CONST) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TypeFingerprint
fingerprint Map TypeFingerprint (TypeDefinition ANY CONST)
lib = MyMap -> GQLResult MyMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TypeFingerprint (TypeDefinition ANY CONST)
lib, Map TypeName [TypeName]
conn)
      | Bool
otherwise = do
        (TypeDefinition cat CONST
type', [MyMap -> GQLResult MyMap]
updates) <- SchemaT cat' (TypeDefinition cat CONST)
-> GQLResult (TypeDefinition cat CONST, [MyMap -> GQLResult MyMap])
forall (cat :: TypeCategory) a.
SchemaT cat a -> GQLResult (a, [MyMap -> GQLResult MyMap])
runSchemaT (a -> SchemaT cat' (TypeDefinition cat CONST)
f a
x)
        MyMap -> [MyMap -> GQLResult MyMap] -> GQLResult MyMap
forall (m :: * -> *) a. Monad m => a -> [a -> m a] -> m a
execUpdates (Map TypeFingerprint (TypeDefinition ANY CONST)
lib, Map TypeName [TypeName]
conn) (TypeDefinition cat CONST -> MyMap -> GQLResult MyMap
update TypeDefinition cat CONST
type' (MyMap -> GQLResult MyMap)
-> [MyMap -> GQLResult MyMap] -> [MyMap -> GQLResult MyMap]
forall a. a -> [a] -> [a]
: [MyMap -> GQLResult MyMap]
updates)
      where
        update :: TypeDefinition cat CONST -> MyMap -> GQLResult MyMap
update TypeDefinition cat CONST
t (Map TypeFingerprint (TypeDefinition ANY CONST)
ts, Map TypeName [TypeName]
c) = MyMap -> GQLResult MyMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeFingerprint
-> TypeDefinition ANY CONST
-> Map TypeFingerprint (TypeDefinition ANY CONST)
-> Map TypeFingerprint (TypeDefinition ANY CONST)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeFingerprint
fingerprint (TypeDefinition cat CONST -> TypeDefinition ANY CONST
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
ToCategory a k ANY =>
a k s -> a ANY s
toAny TypeDefinition cat CONST
t) Map TypeFingerprint (TypeDefinition ANY CONST)
ts, Map TypeName [TypeName]
c)

extendImplements :: TypeName -> [TypeName] -> SchemaT cat' ()
extendImplements :: TypeName -> [TypeName] -> SchemaT cat' ()
extendImplements TypeName
interface [TypeName]
types = GQLResult ((), [MyMap -> GQLResult MyMap]) -> SchemaT cat' ()
forall (cat :: TypeCategory) a.
GQLResult (a, [MyMap -> GQLResult MyMap]) -> SchemaT cat a
SchemaT (GQLResult ((), [MyMap -> GQLResult MyMap]) -> SchemaT cat' ())
-> GQLResult ((), [MyMap -> GQLResult MyMap]) -> SchemaT cat' ()
forall a b. (a -> b) -> a -> b
$ ((), [MyMap -> GQLResult MyMap])
-> GQLResult ((), [MyMap -> GQLResult MyMap])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [MyMap -> GQLResult MyMap
upLib])
  where
    -- TODO: what happens if interface name collides?
    upLib :: MyMap -> GQLResult MyMap
    upLib :: MyMap -> GQLResult MyMap
upLib (Map TypeFingerprint (TypeDefinition ANY CONST)
lib, Map TypeName [TypeName]
con) = MyMap -> GQLResult MyMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TypeFingerprint (TypeDefinition ANY CONST)
lib, (TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName])
-> Map TypeName [TypeName] -> [TypeName] -> Map TypeName [TypeName]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]
insertInterface Map TypeName [TypeName]
con [TypeName]
types)
    insertInterface :: TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]
    insertInterface :: TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]
insertInterface = (Maybe [TypeName] -> Maybe [TypeName])
-> TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter ([TypeName] -> Maybe [TypeName]
forall a. a -> Maybe a
Just ([TypeName] -> Maybe [TypeName])
-> (Maybe [TypeName] -> [TypeName])
-> Maybe [TypeName]
-> Maybe [TypeName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeName
interface TypeName -> [TypeName] -> [TypeName]
forall a. a -> [a] -> [a]
:) ([TypeName] -> [TypeName])
-> (Maybe [TypeName] -> [TypeName])
-> Maybe [TypeName]
-> [TypeName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeName] -> Maybe [TypeName] -> [TypeName]
forall a. a -> Maybe a -> a
fromMaybe [])