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

module Data.Morpheus.Server.Types.TypeName
  ( typeableTypename,
    typeableFingerprint,
    TypeFingerprint (..),
  )
where

-- MORPHEUS

import Data.Data (tyConFingerprint)
import Data.Morpheus.App.Internal.Resolving
  ( Resolver,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded (CatType (..))
import Data.Morpheus.Server.Types.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
    )

typeableTypename :: Typeable a => f a -> TypeName
typeableTypename :: forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> TypeName
typeableTypename = 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 (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 {k} (a :: k) (f :: k -> *). Typeable a => f a -> [TyCon]
getTypeConstructors

typeableFingerprint :: Typeable a => CatType c a -> TypeFingerprint
typeableFingerprint :: forall {k} (a :: k) (c :: TypeCategory).
Typeable a =>
CatType c a -> TypeFingerprint
typeableFingerprint p :: CatType c a
p@CatType c a
InputType = TypeCategory -> [Fingerprint] -> TypeFingerprint
TypeableFingerprint TypeCategory
IN forall a b. (a -> b) -> a -> b
$ TyCon -> Fingerprint
tyConFingerprint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> [TyCon]
getTypeConstructors CatType c a
p
typeableFingerprint p :: CatType c a
p@CatType c a
OutputType = TypeCategory -> [Fingerprint] -> TypeFingerprint
TypeableFingerprint TypeCategory
OUT forall a b. (a -> b) -> a -> b
$ TyCon -> Fingerprint
tyConFingerprint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> [TyCon]
getTypeConstructors CatType c a
p

getTypeConstructors :: Typeable a => f a -> [TyCon]
getTypeConstructors :: forall {k} (a :: k) (f :: k -> *). 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

rep :: forall k (a :: k) f. Typeable a => f a -> TyCon
rep :: forall k (a :: k) (f :: k -> *). Typeable a => f a -> TyCon
rep = TypeRep -> TyCon
typeRepTyCon 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 | forall k (a :: k) (f :: k -> *). Typeable a => f a -> TyCon
rep (forall {k} (t :: k). Proxy t
Proxy @(Int, Int)) forall a. Eq a => a -> a -> Bool
== TyCon
x = forall k (a :: k) (f :: k -> *). Typeable a => f a -> TyCon
rep (forall {k} (t :: k). Proxy t
Proxy @(Pair Int Int))
replacePairCon TyCon
x = TyCon
x

ignoredTypes :: [TyCon]
ignoredTypes :: [TyCon]
ignoredTypes =
  [ forall k (a :: k) (f :: k -> *). Typeable a => f a -> TyCon
rep (forall {k} (t :: k). Proxy t
Proxy @Resolver),
    forall k (a :: k) (f :: k -> *). Typeable a => f a -> TyCon
rep (forall {k} (t :: k). Proxy t
Proxy @NamedResolverT)
  ]

-- ignores resolver names from typename
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver (TyCon
con, [TypeRep]
_) | TyCon
con forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TyCon]
ignoredTypes = []
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