{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Utils.Kinded
  ( KindedProxy (..),
    setType,
    setKind,
    kinded,
    CatType (..),
    inputType,
    outputType,
    CatContext (..),
    getCat,
    typeCat,
    unliftKind,
    catMap,
    addContext,
    getCatContext,
    mkScalar,
  )
where

import Data.Morpheus.Types.Internal.AST
  ( IN,
    OUT,
    ScalarDefinition,
    TRUE,
    TypeCategory (..),
    TypeContent (..),
  )
import Prelude (Show)

-- | context , like Proxy with multiple parameters
-- * 'kind': object, scalar, enum ...
-- * 'a': actual gql type
data KindedProxy k a
  = KindedProxy

setType :: f a -> kinded (k :: t) a' -> KindedProxy k a
setType :: forall {k} {k} (f :: k -> *) (a :: k) t (kinded :: t -> k -> *)
       (k :: t) (a' :: k).
f a -> kinded k a' -> KindedProxy k a
setType f a
_ kinded k a'
_ = forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy

setKind :: f k -> kinded (k' :: t) a -> KindedProxy k a
setKind :: forall {k} {k} (f :: k -> *) (k :: k) t (kinded :: t -> k -> *)
       (k' :: t) (a :: k).
f k -> kinded k' a -> KindedProxy k a
setKind f k
_ kinded k' a
_ = forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy

kinded :: f k -> f' a -> KindedProxy k a
kinded :: forall {k} {k} (f :: k -> *) (k :: k) (f' :: k -> *) (a :: k).
f k -> f' a -> KindedProxy k a
kinded f k
_ f' a
_ = forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy

data CatContext (cat :: TypeCategory) where
  InputContext :: CatContext IN
  OutputContext :: CatContext OUT

data CatType (cat :: TypeCategory) a where
  InputType :: CatType IN a
  OutputType :: CatType OUT a

-- liftKind :: CatType cat a -> CatType cat (f k a)
-- liftKind InputType = InputType
-- liftKind OutputType = OutputType

deriving instance Show (CatType cat a)

-- converts:
--   f a -> KindedType IN a
-- or
--  f k a -> KindedType IN a
inputType :: f a -> CatType IN a
inputType :: forall {k} (f :: k -> *) (a :: k). f a -> CatType 'IN a
inputType f a
_ = forall {k} (a :: k). CatType 'IN a
InputType

outputType :: f a -> CatType OUT a
outputType :: forall {k} (f :: k -> *) (a :: k). f a -> CatType 'OUT a
outputType f a
_ = forall {k} (a :: k). CatType 'OUT a
OutputType

unliftKind :: CatType cat (f k a) -> CatType cat a
unliftKind :: forall {k} {k} {k} (cat :: TypeCategory) (f :: k -> k -> k)
       (k :: k) (a :: k).
CatType cat (f k a) -> CatType cat a
unliftKind CatType cat (f k a)
InputType = forall {k} (a :: k). CatType 'IN a
InputType
unliftKind CatType cat (f k a)
OutputType = forall {k} (a :: k). CatType 'OUT a
OutputType

catMap :: f a -> CatType cat b -> CatType cat a
catMap :: forall {k} {k} (f :: k -> *) (a :: k) (cat :: TypeCategory)
       (b :: k).
f a -> CatType cat b -> CatType cat a
catMap f a
_ CatType cat b
InputType = forall {k} (a :: k). CatType 'IN a
InputType
catMap f a
_ CatType cat b
OutputType = forall {k} (a :: k). CatType 'OUT a
OutputType

getCat :: CatContext c -> TypeCategory
getCat :: forall (c :: TypeCategory). CatContext c -> TypeCategory
getCat CatContext c
InputContext = TypeCategory
IN
getCat CatContext c
OutputContext = TypeCategory
OUT

typeCat :: CatType c a -> TypeCategory
typeCat :: forall {k} (c :: TypeCategory) (a :: k).
CatType c a -> TypeCategory
typeCat CatType c a
InputType = TypeCategory
IN
typeCat CatType c a
OutputType = TypeCategory
OUT

addContext :: CatContext c -> f a -> CatType c a
addContext :: forall {k} (c :: TypeCategory) (f :: k -> *) (a :: k).
CatContext c -> f a -> CatType c a
addContext CatContext c
InputContext f a
_ = forall {k} (a :: k). CatType 'IN a
InputType
addContext CatContext c
OutputContext f a
_ = forall {k} (a :: k). CatType 'OUT a
OutputType

getCatContext :: CatType c a -> CatContext c
getCatContext :: forall {k} (c :: TypeCategory) (a :: k).
CatType c a -> CatContext c
getCatContext CatType c a
InputType = CatContext 'IN
InputContext
getCatContext CatType c a
OutputType = CatContext 'OUT
OutputContext

mkScalar :: CatType c a -> ScalarDefinition -> TypeContent TRUE c s
mkScalar :: forall {k} (c :: TypeCategory) (a :: k) (s :: Stage).
CatType c a -> ScalarDefinition -> TypeContent TRUE c s
mkScalar CatType c a
InputType ScalarDefinition
f = forall (a :: TypeCategory) (s :: Stage).
ScalarDefinition -> TypeContent (LEAF <=? a) a s
DataScalar ScalarDefinition
f
mkScalar CatType c a
OutputType ScalarDefinition
f = forall (a :: TypeCategory) (s :: Stage).
ScalarDefinition -> TypeContent (LEAF <=? a) a s
DataScalar ScalarDefinition
f