Use.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Morpheus.Server.Deriving.Utils.Use
  ( UseDeriving (..),
    GQLTypeCTX (..),
    UseGQLValue (..),
    UseResolver (..),
    UseNamedResolver (..),
    UseRef (..),
    UseGQLType (..),
    GQLValueCTX (..),
    useDecodeArguments,
  )
where

import Data.Morpheus.App.Internal.Resolving (NamedResolver (..), ResolverState, ResolverValue)
import Data.Morpheus.Generic (ScanRef)
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Server.Deriving.Utils.GScan (FreeCatType)
import Data.Morpheus.Server.Deriving.Utils.Types
import Data.Morpheus.Server.Types.Directives
  ( GDirectiveUsages (..),
  )
import Data.Morpheus.Server.Types.Internal
import Data.Morpheus.Server.Types.TypeName
  ( TypeFingerprint,
  )
import Data.Morpheus.Types.Internal.AST
  ( Arguments,
    ArgumentsDefinition,
    CONST,
    TypeName,
    TypeWrapper,
    VALID,
    ValidValue,
    Value,
  )
import Relude

data UseRef (c :: Type -> Constraint) where
  UseRef :: (c a) => CatType t a -> UseRef c

class UseGQLType ctx con | ctx -> con where
  useFingerprint :: (con a) => ctx -> CatType c a -> TypeFingerprint
  useTypename :: (con a) => ctx -> CatType c a -> TypeName
  useWrappers :: (con a) => ctx -> CatType c a -> TypeWrapper
  useDeriveNode :: (con a) => ctx -> CatType c a -> GQLResult (GQLTypeNode c)
  useDeriveFieldArgs :: (con a) => ctx -> CatType c a -> GQLResult (ArgumentsDefinition CONST)
  useExploreRef :: (con a) => ctx -> CatType c a -> [ScanRef FreeCatType con]

data GQLTypeCTX gql = GQLTypeCTX
  { __useFingerprint :: forall c a. (gql a) => CatType c a -> TypeFingerprint,
    __useTypename :: forall c a. (gql a) => CatType c a -> TypeName,
    __useTypeData :: forall c a. (gql a) => CatType c a -> TypeData,
    __useDeriveNode :: forall c a. (gql a) => CatType c a -> GQLResult (GQLTypeNode c),
    __useDeriveFieldArgs :: forall c a. (gql a) => CatType c a -> GQLResult (ArgumentsDefinition CONST),
    __useExploreRef :: forall c a. (gql a) => CatType c a -> [ScanRef FreeCatType gql]
  }

instance UseGQLType (GQLTypeCTX gql) gql where
  useFingerprint GQLTypeCTX {__useFingerprint} = __useFingerprint
  useTypename GQLTypeCTX {__useTypename} = __useTypename
  useWrappers GQLTypeCTX {__useTypeData} = gqlWrappers . __useTypeData
  useDeriveNode GQLTypeCTX {__useDeriveNode} = __useDeriveNode
  useDeriveFieldArgs GQLTypeCTX {__useDeriveFieldArgs} = __useDeriveFieldArgs
  useExploreRef GQLTypeCTX {__useExploreRef} = __useExploreRef

data GQLValueCTX val = GQLValueCTX
  { __useEncodeValue :: forall a. (val a) => a -> GQLResult (Value CONST),
    __useDecodeValue :: forall a. (val a) => ValidValue -> ResolverState a
  }

class UseGQLValue ctx con | ctx -> con where
  useEncodeValue :: (con a) => ctx -> a -> GQLResult (Value CONST)
  useDecodeValue :: (con a) => ctx -> ValidValue -> ResolverState a

instance UseGQLValue (GQLValueCTX val) val where
  useEncodeValue GQLValueCTX {__useEncodeValue} = __useEncodeValue
  useDecodeValue GQLValueCTX {__useDecodeValue} = __useDecodeValue

data UseDeriving gql val = UseDeriving
  { useDirectives :: forall f a. (gql a) => f a -> GDirectiveUsages gql val,
    __useValue :: GQLValueCTX val,
    __useGQL :: GQLTypeCTX gql
  }

instance UseGQLType (UseDeriving gql val) gql where
  useFingerprint = useFingerprint . __useGQL
  useTypename = useTypename . __useGQL
  useWrappers = useWrappers . __useGQL
  useDeriveNode = useDeriveNode . __useGQL
  useDeriveFieldArgs = useDeriveFieldArgs . __useGQL
  useExploreRef = useExploreRef . __useGQL

instance UseGQLValue (UseDeriving gql val) val where
  useEncodeValue = useEncodeValue . __useValue
  useDecodeValue = useDecodeValue . __useValue

data UseResolver res gql val = UseResolver
  { useEncodeResolver :: forall a m. (res m a) => a -> m (ResolverValue m),
    resDrv :: UseDeriving gql val
  }

instance UseGQLType (UseResolver res gql val) gql where
  useFingerprint = useFingerprint . resDrv
  useTypename = useTypename . resDrv
  useWrappers = useWrappers . resDrv
  useDeriveNode = useDeriveNode . resDrv
  useDeriveFieldArgs = useDeriveFieldArgs . resDrv
  useExploreRef = useExploreRef . resDrv

instance UseGQLValue (UseResolver res gql val) val where
  useEncodeValue = useEncodeValue . resDrv
  useDecodeValue = useDecodeValue . resDrv

data UseNamedResolver named fun gql val = UseNamedResolver
  { useNamedFieldResolver :: forall a m. (fun m a) => a -> m (ResolverValue m),
    useDeriveNamedResolvers :: forall f a m. (named m a) => f a -> [NamedResolver m],
    useDeriveNamedRefs :: forall f a m. (named m a) => f a -> [ScanRef Proxy (named m)],
    namedDrv :: UseDeriving gql val
  }

instance UseGQLType (UseNamedResolver named res gql val) gql where
  useFingerprint = useFingerprint . namedDrv
  useTypename = useTypename . namedDrv
  useWrappers = useWrappers . namedDrv
  useDeriveNode = useDeriveNode . namedDrv
  useDeriveFieldArgs = useDeriveFieldArgs . namedDrv
  useExploreRef = useExploreRef . namedDrv

useDecodeArguments :: (val a) => UseDeriving gql val -> Arguments VALID -> ResolverState a
useDecodeArguments ctx = useDecodeValue ctx . argumentsToObject