{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

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

import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..), foldM)
import Data.Function ((&))
import Data.Functor ((<$>), Functor (..))
import Data.Map
  ( Map,
    elems,
    empty,
    insert,
    member,
  )
import Data.Morpheus.Internal.Utils
  ( Failure (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    CONST,
    CONST,
    OBJECT,
    Schema (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    defineSchemaWith,
    toAny,
  )
import Data.Morpheus.Types.Internal.Resolving
  ( Eventless,
  )
import Data.Semigroup (Semigroup (..))
import GHC.Fingerprint.Type (Fingerprint)
import GHC.Generics (Generic)
import Prelude
  ( ($),
    (.),
    Eq (..),
    Maybe (..),
    Ord,
    Show,
    const,
    null,
    otherwise,
  )

data TypeFingerprint
  = TypeableFingerprint [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)

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

instance
  Failure err Eventless =>
  Failure err SchemaT
  where
  failure :: err -> SchemaT v
failure = Eventless (v, [MyMap -> Eventless MyMap]) -> SchemaT v
forall a. Eventless (a, [MyMap -> Eventless MyMap]) -> SchemaT a
SchemaT (Eventless (v, [MyMap -> Eventless MyMap]) -> SchemaT v)
-> (err -> Eventless (v, [MyMap -> Eventless MyMap]))
-> err
-> SchemaT v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Eventless (v, [MyMap -> Eventless MyMap])
forall error (f :: * -> *) v. Failure error f => error -> f v
failure

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

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

toSchema ::
  SchemaT
    ( TypeDefinition OBJECT CONST,
      TypeDefinition OBJECT CONST,
      TypeDefinition OBJECT CONST
    ) ->
  Eventless (Schema CONST)
toSchema :: SchemaT
  (TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
   TypeDefinition OBJECT CONST)
-> Eventless (Schema CONST)
toSchema (SchemaT Eventless
  ((TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
    TypeDefinition OBJECT CONST),
   [MyMap -> Eventless MyMap])
v) = do
  ((TypeDefinition OBJECT CONST
q, TypeDefinition OBJECT CONST
m, TypeDefinition OBJECT CONST
s), [MyMap -> Eventless MyMap]
typeDefs) <- Eventless
  ((TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
    TypeDefinition OBJECT CONST),
   [MyMap -> Eventless MyMap])
v
  [TypeDefinition ANY CONST]
types <- MyMap -> [TypeDefinition ANY CONST]
forall k a. Map k a -> [a]
elems (MyMap -> [TypeDefinition ANY CONST])
-> Eventless MyMap -> Result () [TypeDefinition ANY CONST]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MyMap -> [MyMap -> Eventless MyMap] -> Eventless MyMap
forall (m :: * -> *) a. Monad m => a -> [a -> m a] -> m a
execUpdates MyMap
forall k a. Map k a
empty [MyMap -> Eventless MyMap]
typeDefs
  [TypeDefinition ANY CONST]
-> (Maybe (TypeDefinition OBJECT CONST),
    Maybe (TypeDefinition OBJECT CONST),
    Maybe (TypeDefinition OBJECT CONST))
-> Eventless (Schema CONST)
forall (f :: * -> *) (cat :: TypeCategory) (s :: Stage).
(Monad f, Failure ValidationErrors 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)
optionalType TypeDefinition OBJECT CONST
q, TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST)
optionalType TypeDefinition OBJECT CONST
m, TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST)
optionalType TypeDefinition OBJECT CONST
s)

optionalType :: TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST)
optionalType :: TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST)
optionalType td :: TypeDefinition OBJECT CONST
td@TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {FieldsDefinition OUT CONST
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT CONST
objectFields}}
  | FieldsDefinition OUT CONST -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FieldsDefinition OUT CONST
objectFields = Maybe (TypeDefinition OBJECT CONST)
forall a. Maybe a
Nothing
  | Bool
otherwise = TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST)
forall a. a -> Maybe a
Just TypeDefinition OBJECT CONST
td

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
foldM a -> (a -> m a) -> m a
forall a b. a -> (a -> b) -> b
(&)

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

updateSchema ::
  TypeFingerprint ->
  (a -> SchemaT (TypeDefinition cat CONST)) ->
  a ->
  SchemaT ()
updateSchema :: TypeFingerprint
-> (a -> SchemaT (TypeDefinition cat CONST)) -> a -> SchemaT ()
updateSchema InternalFingerprint {} a -> SchemaT (TypeDefinition cat CONST)
_ a
_ = Eventless ((), [MyMap -> Eventless MyMap]) -> SchemaT ()
forall a. Eventless (a, [MyMap -> Eventless MyMap]) -> SchemaT a
SchemaT (Eventless ((), [MyMap -> Eventless MyMap]) -> SchemaT ())
-> Eventless ((), [MyMap -> Eventless MyMap]) -> SchemaT ()
forall a b. (a -> b) -> a -> b
$ ((), [MyMap -> Eventless MyMap])
-> Eventless ((), [MyMap -> Eventless MyMap])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [])
updateSchema TypeFingerprint
fingerprint a -> SchemaT (TypeDefinition cat CONST)
f a
x =
  Eventless ((), [MyMap -> Eventless MyMap]) -> SchemaT ()
forall a. Eventless (a, [MyMap -> Eventless MyMap]) -> SchemaT a
SchemaT (Eventless ((), [MyMap -> Eventless MyMap]) -> SchemaT ())
-> Eventless ((), [MyMap -> Eventless MyMap]) -> SchemaT ()
forall a b. (a -> b) -> a -> b
$ ((), [MyMap -> Eventless MyMap])
-> Eventless ((), [MyMap -> Eventless MyMap])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [MyMap -> Eventless MyMap
upLib])
  where
    upLib :: MyMap -> Eventless MyMap
    upLib :: MyMap -> Eventless MyMap
upLib MyMap
lib
      | TypeFingerprint -> MyMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
member TypeFingerprint
fingerprint MyMap
lib = MyMap -> Eventless MyMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure MyMap
lib
      | Bool
otherwise = do
        (TypeDefinition cat CONST
type', [MyMap -> Eventless MyMap]
updates) <- SchemaT (TypeDefinition cat CONST)
-> Eventless (TypeDefinition cat CONST, [MyMap -> Eventless MyMap])
forall a. SchemaT a -> Eventless (a, [MyMap -> Eventless MyMap])
runSchemaT (a -> SchemaT (TypeDefinition cat CONST)
f a
x)
        MyMap -> [MyMap -> Eventless MyMap] -> Eventless MyMap
forall (m :: * -> *) a. Monad m => a -> [a -> m a] -> m a
execUpdates MyMap
lib ((MyMap -> Eventless MyMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MyMap -> Eventless MyMap)
-> (MyMap -> MyMap) -> MyMap -> Eventless MyMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeFingerprint -> TypeDefinition ANY CONST -> MyMap -> MyMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
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
type')) (MyMap -> Eventless MyMap)
-> [MyMap -> Eventless MyMap] -> [MyMap -> Eventless MyMap]
forall a. a -> [a] -> [a]
: [MyMap -> Eventless MyMap]
updates)