{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Types.TypeName
  ( getTypename,
    getTypeConstructorNames,
    getFingerprint,
    TypeFingerprint (..),
  )
where

-- MORPHEUS

import Data.Data (tyConFingerprint)
import Data.Morpheus.App.Internal.Resolving
  ( Resolver,
  )
import Data.Morpheus.NamedResolvers (NamedResolverT (..))
import Data.Morpheus.Server.Types.Types
  ( Pair,
  )
import Data.Morpheus.Types.Internal.AST
  ( TypeCategory,
    TypeName,
    packName,
  )
import Data.Text
  ( intercalate,
    pack,
  )
import Data.Typeable
  ( TyCon,
    TypeRep,
    splitTyConApp,
    tyConName,
    typeRep,
    typeRepTyCon,
  )
import GHC.Fingerprint
import Relude hiding (Seq, Undefined, intercalate)

data TypeFingerprint
  = TypeableFingerprint TypeCategory [Fingerprint]
  | InternalFingerprint TypeName
  | CustomFingerprint TypeName
  deriving
    ( 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
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
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
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
Ord
    )

getTypename :: Typeable a => f a -> TypeName
getTypename :: forall a (f :: * -> *). Typeable a => f a -> TypeName
getTypename = forall a (t :: NAME). NamePacking a => a -> Name t
packName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
intercalate Text
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *). Typeable a => f a -> [Text]
getTypeConstructorNames

getTypeConstructorNames :: Typeable a => f a -> [Text]
getTypeConstructorNames :: forall a (f :: * -> *). Typeable a => f a -> [Text]
getTypeConstructorNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> String
tyConName forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> TyCon
replacePairCon) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *). Typeable a => f a -> [TyCon]
getTypeConstructors

getTypeConstructors :: Typeable a => f a -> [TyCon]
getTypeConstructors :: forall a (f :: * -> *). Typeable a => f a -> [TyCon]
getTypeConstructors = (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TyCon, [TypeRep])
splitTyConApp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep

-- | replaces typeName (A,B) with Pair_A_B
replacePairCon :: TyCon -> TyCon
replacePairCon :: TyCon -> TyCon
replacePairCon TyCon
x | TyCon
hsPair forall a. Eq a => a -> a -> Bool
== TyCon
x = TyCon
gqlPair
  where
    hsPair :: TyCon
hsPair = TypeRep -> TyCon
typeRepTyCon forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(Int, Int)
    gqlPair :: TyCon
gqlPair = TypeRep -> TyCon
typeRepTyCon forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(Pair Int Int)
replacePairCon TyCon
x = TyCon
x

-- Ignores Resolver name  from typeName
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver (TyCon
con, [TypeRep]
_) | TyCon
con forall a. Eq a => a -> a -> Bool
== TypeRep -> TyCon
typeRepTyCon (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @Resolver) = []
ignoreResolver (TyCon
con, [TypeRep]
_) | TyCon
con forall a. Eq a => a -> a -> Bool
== TypeRep -> TyCon
typeRepTyCon (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @NamedResolverT) = []
ignoreResolver (TyCon
con, [TypeRep]
args) =
  TyCon
con forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((TyCon, [TypeRep]) -> [TyCon]
ignoreResolver forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TyCon, [TypeRep])
splitTyConApp) [TypeRep]
args

getFingerprint :: Typeable a => TypeCategory -> f a -> TypeFingerprint
getFingerprint :: forall a (f :: * -> *).
Typeable a =>
TypeCategory -> f a -> TypeFingerprint
getFingerprint TypeCategory
category = TypeCategory -> [Fingerprint] -> TypeFingerprint
TypeableFingerprint TypeCategory
category forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCon -> Fingerprint
tyConFingerprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *). Typeable a => f a -> [TyCon]
getTypeConstructors