{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Utils.GTraversable where

import qualified Data.Map as M
import Data.Morpheus.Kind
import Data.Morpheus.NamedResolvers (NamedResolverT)
import Data.Morpheus.Server.Deriving.Utils.Kinded
import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __type), TypeData (gqlFingerprint))
import Data.Morpheus.Server.Types.SchemaT (TypeFingerprint)
import Data.Morpheus.Types.Internal.AST
import GHC.Generics
import Relude hiding (Undefined)

traverseTypes ::
  (GFmap (ScanConstraint c) (KIND a) a, c (KIND a) a, GQLType a) =>
  Mappable c v KindedProxy ->
  Proxy a ->
  Map TypeFingerprint v
traverseTypes :: Mappable c v KindedProxy -> Proxy a -> Map TypeFingerprint v
traverseTypes Mappable c v KindedProxy
f = Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy
-> forall a.
   (GQLType a, ScanConstraint c (KIND a) a) =>
   KindedProxy (KIND a) a -> Map TypeFingerprint v
forall (c :: DerivingKind -> * -> Constraint) v
       (f :: DerivingKind -> * -> *).
Mappable c v f
-> forall a.
   (GQLType a, c (KIND a) a) =>
   KindedProxy (KIND a) a -> v
runMappable (Mappable c v KindedProxy
-> Map TypeFingerprint v
-> Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy
forall (c :: DerivingKind -> * -> Constraint) v.
Mappable c v KindedProxy
-> Map TypeFingerprint v
-> Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy
scanner Mappable c v KindedProxy
f Map TypeFingerprint v
forall a. Monoid a => a
mempty) (KindedProxy (KIND a) a -> Map TypeFingerprint v)
-> (Proxy a -> KindedProxy (KIND a) a)
-> Proxy a
-> Map TypeFingerprint v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> KindedProxy (KIND a) a
forall (proxy :: * -> *) a. proxy a -> KindedProxy (KIND a) a
withDerivable

class
  (GFmap (ScanConstraint c) (KIND a) a, c (KIND a) a) =>
  ScanConstraint
    (c :: DerivingKind -> Type -> Constraint)
    (k :: DerivingKind)
    (a :: Type)

instance (GFmap (ScanConstraint c) (KIND a) a, c (KIND a) a) => ScanConstraint c k a

scanner ::
  Mappable c v KindedProxy ->
  Map TypeFingerprint v ->
  Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy
scanner :: Mappable c v KindedProxy
-> Map TypeFingerprint v
-> Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy
scanner c :: Mappable c v KindedProxy
c@(Mappable forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v
f) Map TypeFingerprint v
lib =
  (forall a.
 (GQLType a, ScanConstraint c (KIND a) a) =>
 KindedProxy (KIND a) a -> Map TypeFingerprint v)
-> Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy
forall (c :: DerivingKind -> * -> Constraint) v
       (f :: DerivingKind -> * -> *).
(forall a.
 (GQLType a, c (KIND a) a) =>
 KindedProxy (KIND a) a -> v)
-> Mappable c v f
Mappable
    ( \KindedProxy (KIND a) a
proxy -> do
        let typeInfo :: TypeData
typeInfo = KindedProxy (KIND a) a -> TypeCategory -> TypeData
forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type KindedProxy (KIND a) a
proxy TypeCategory
OUT
        let fingerprint :: TypeFingerprint
fingerprint = TypeData -> TypeFingerprint
gqlFingerprint TypeData
typeInfo
        if TypeFingerprint -> Map TypeFingerprint v -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member TypeFingerprint
fingerprint Map TypeFingerprint v
lib
          then Map TypeFingerprint v
lib
          else do
            let newLib :: Map TypeFingerprint v
newLib = TypeFingerprint
-> v -> Map TypeFingerprint v -> Map TypeFingerprint v
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TypeFingerprint
fingerprint (KindedProxy (KIND a) a -> v
forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v
f KindedProxy (KIND a) a
proxy) Map TypeFingerprint v
lib
            Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy
-> KindedProxy (KIND a) a -> Map TypeFingerprint v
forall k (c :: DerivingKind -> * -> Constraint) (t :: DerivingKind)
       (a :: k) v (kinded :: DerivingKind -> k -> *).
(GFmap c t a, Monoid v, Semigroup v) =>
Mappable c v KindedProxy -> kinded t a -> v
gfmap (Mappable c v KindedProxy
-> Map TypeFingerprint v
-> Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy
forall (c :: DerivingKind -> * -> Constraint) v.
Mappable c v KindedProxy
-> Map TypeFingerprint v
-> Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy
scanner Mappable c v KindedProxy
c Map TypeFingerprint v
newLib) KindedProxy (KIND a) a
proxy
    )

withDerivable :: proxy a -> KindedProxy (KIND a) a
withDerivable :: proxy a -> KindedProxy (KIND a) a
withDerivable proxy a
_ = KindedProxy (KIND a) a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy

newtype Mappable (c :: DerivingKind -> Type -> Constraint) (v :: Type) (f :: DerivingKind -> Type -> Type) = Mappable
  { Mappable c v f
-> forall a.
   (GQLType a, c (KIND a) a) =>
   KindedProxy (KIND a) a -> v
runMappable :: forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v
  }

-- Map
class GFmap (c :: DerivingKind -> Type -> Constraint) (t :: DerivingKind) a where
  gfmap :: (Monoid v, Semigroup v) => Mappable c v KindedProxy -> kinded t a -> v

instance (GQLType a, c (KIND a) a) => GFmap c SCALAR a where
  gfmap :: Mappable c v KindedProxy -> kinded SCALAR a -> v
gfmap (Mappable forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v
f) kinded SCALAR a
_ = KindedProxy (KIND a) a -> v
forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v
f (KindedProxy (KIND a) a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND a) a)

instance (GQLType a, c (KIND a) a, GFunctor c (Rep a)) => GFmap c TYPE a where
  gfmap :: Mappable c v KindedProxy -> kinded TYPE a -> v
gfmap f :: Mappable c v KindedProxy
f@(Mappable forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v
fx) kinded TYPE a
_ = KindedProxy (KIND a) a -> v
forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v
fx (KindedProxy (KIND a) a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND a) a) v -> v -> v
forall a. Semigroup a => a -> a -> a
<> Mappable c v KindedProxy -> Proxy (Rep a) -> v
forall k (c :: DerivingKind -> * -> Constraint) (a :: k) v
       (p :: DerivingKind -> * -> *) (proxy :: k -> *).
(GFunctor c a, Monoid v, Semigroup v) =>
Mappable c v p -> proxy a -> v
genericMap Mappable c v KindedProxy
f (Proxy (Rep a)
forall k (t :: k). Proxy t
Proxy @(Rep a))

instance GFmap c (KIND a) a => GFmap c WRAPPER (f a) where
  gfmap :: Mappable c v KindedProxy -> kinded WRAPPER (f a) -> v
gfmap Mappable c v KindedProxy
f kinded WRAPPER (f a)
_ = Mappable c v KindedProxy -> KindedProxy (KIND a) a -> v
forall k (c :: DerivingKind -> * -> Constraint) (t :: DerivingKind)
       (a :: k) v (kinded :: DerivingKind -> k -> *).
(GFmap c t a, Monoid v, Semigroup v) =>
Mappable c v KindedProxy -> kinded t a -> v
gfmap Mappable c v KindedProxy
f (KindedProxy (KIND a) a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND a) a)

instance GFmap c (KIND a) a => GFmap c CUSTOM (input -> a) where
  gfmap :: Mappable c v KindedProxy -> kinded CUSTOM (input -> a) -> v
gfmap Mappable c v KindedProxy
f kinded CUSTOM (input -> a)
_ = Mappable c v KindedProxy -> KindedProxy (KIND a) a -> v
forall k (c :: DerivingKind -> * -> Constraint) (t :: DerivingKind)
       (a :: k) v (kinded :: DerivingKind -> k -> *).
(GFmap c t a, Monoid v, Semigroup v) =>
Mappable c v KindedProxy -> kinded t a -> v
gfmap Mappable c v KindedProxy
f (KindedProxy (KIND a) a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND a) a)

instance GFmap c (KIND a) a => GFmap c CUSTOM (NamedResolverT m a) where
  gfmap :: Mappable c v KindedProxy -> kinded CUSTOM (NamedResolverT m a) -> v
gfmap Mappable c v KindedProxy
f kinded CUSTOM (NamedResolverT m a)
_ = Mappable c v KindedProxy -> KindedProxy (KIND a) a -> v
forall k (c :: DerivingKind -> * -> Constraint) (t :: DerivingKind)
       (a :: k) v (kinded :: DerivingKind -> k -> *).
(GFmap c t a, Monoid v, Semigroup v) =>
Mappable c v KindedProxy -> kinded t a -> v
gfmap Mappable c v KindedProxy
f (KindedProxy (KIND a) a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND a) a)

--
--
-- GFunctor
--
--
class GFunctor (c :: DerivingKind -> Type -> Constraint) a where
  genericMap :: (Monoid v, Semigroup v) => Mappable c v p -> proxy a -> v

instance (Datatype d, GFunctor c a) => GFunctor c (M1 D d a) where
  genericMap :: Mappable c v p -> proxy (M1 D d a) -> v
genericMap Mappable c v p
fun proxy (M1 D d a)
_ = Mappable c v p -> Proxy a -> v
forall k (c :: DerivingKind -> * -> Constraint) (a :: k) v
       (p :: DerivingKind -> * -> *) (proxy :: k -> *).
(GFunctor c a, Monoid v, Semigroup v) =>
Mappable c v p -> proxy a -> v
genericMap Mappable c v p
fun (Proxy a
forall k (t :: k). Proxy t
Proxy @a)

instance (GFunctor con a) => GFunctor con (M1 C c a) where
  genericMap :: Mappable con v p -> proxy (M1 C c a) -> v
genericMap Mappable con v p
f proxy (M1 C c a)
_ = Mappable con v p -> Proxy a -> v
forall k (c :: DerivingKind -> * -> Constraint) (a :: k) v
       (p :: DerivingKind -> * -> *) (proxy :: k -> *).
(GFunctor c a, Monoid v, Semigroup v) =>
Mappable c v p -> proxy a -> v
genericMap Mappable con v p
f (Proxy a
forall k (t :: k). Proxy t
Proxy @a)

instance (GFunctor c a, GFunctor c b) => GFunctor c (a :+: b) where
  genericMap :: Mappable c v p -> proxy (a :+: b) -> v
genericMap Mappable c v p
fun proxy (a :+: b)
_ = Mappable c v p -> Proxy a -> v
forall k (c :: DerivingKind -> * -> Constraint) (a :: k) v
       (p :: DerivingKind -> * -> *) (proxy :: k -> *).
(GFunctor c a, Monoid v, Semigroup v) =>
Mappable c v p -> proxy a -> v
genericMap Mappable c v p
fun (Proxy a
forall k (t :: k). Proxy t
Proxy @a) v -> v -> v
forall a. Semigroup a => a -> a -> a
<> Mappable c v p -> Proxy b -> v
forall k (c :: DerivingKind -> * -> Constraint) (a :: k) v
       (p :: DerivingKind -> * -> *) (proxy :: k -> *).
(GFunctor c a, Monoid v, Semigroup v) =>
Mappable c v p -> proxy a -> v
genericMap Mappable c v p
fun (Proxy b
forall k (t :: k). Proxy t
Proxy @b)

instance (GFunctor c a, GFunctor c b) => GFunctor c (a :*: b) where
  genericMap :: Mappable c v p -> proxy (a :*: b) -> v
genericMap Mappable c v p
fun proxy (a :*: b)
_ = Mappable c v p -> Proxy a -> v
forall k (c :: DerivingKind -> * -> Constraint) (a :: k) v
       (p :: DerivingKind -> * -> *) (proxy :: k -> *).
(GFunctor c a, Monoid v, Semigroup v) =>
Mappable c v p -> proxy a -> v
genericMap Mappable c v p
fun (Proxy a
forall k (t :: k). Proxy t
Proxy @a) v -> v -> v
forall a. Semigroup a => a -> a -> a
<> Mappable c v p -> Proxy b -> v
forall k (c :: DerivingKind -> * -> Constraint) (a :: k) v
       (p :: DerivingKind -> * -> *) (proxy :: k -> *).
(GFunctor c a, Monoid v, Semigroup v) =>
Mappable c v p -> proxy a -> v
genericMap Mappable c v p
fun (Proxy b
forall k (t :: k). Proxy t
Proxy @b)

instance (GQLType a, c (KIND a) a) => GFunctor c (M1 S s (K1 x a)) where
  genericMap :: Mappable c v p -> proxy (M1 S s (K1 x a)) -> v
genericMap (Mappable forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v
f) proxy (M1 S s (K1 x a))
_ = KindedProxy (KIND a) a -> v
forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v
f (KindedProxy (KIND a) a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND a) a)

instance GFunctor c U1 where
  genericMap :: Mappable c v p -> proxy U1 -> v
genericMap Mappable c v p
_ proxy U1
_ = v
forall a. Monoid a => a
mempty