{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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,
    unpackName,
  )
import Data.Text
  ( intercalate,
    pack,
    unpack,
  )
import Data.Typeable
  ( TyCon,
    TypeRep,
    splitTyConApp,
    tyConName,
    typeRep,
    typeRepTyCon,
  )
import GHC.Fingerprint
import Relude hiding (Seq, Show, Undefined, intercalate, show)
import Prelude (Show (..))

data TypeFingerprint
  = TypeableFingerprint
      { TypeFingerprint -> TypeCategory
category :: TypeCategory,
        TypeFingerprint -> [Fingerprint]
fingerprints :: [Fingerprint]
      }
  | InternalFingerprint TypeName
  | CustomFingerprint TypeName
  deriving
    ( (forall x. TypeFingerprint -> Rep TypeFingerprint x)
-> (forall x. Rep TypeFingerprint x -> TypeFingerprint)
-> Generic TypeFingerprint
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
$cfrom :: forall x. TypeFingerprint -> Rep TypeFingerprint x
from :: forall x. TypeFingerprint -> Rep TypeFingerprint x
$cto :: forall x. Rep TypeFingerprint x -> TypeFingerprint
to :: forall x. Rep TypeFingerprint x -> TypeFingerprint
Generic,
      TypeFingerprint -> TypeFingerprint -> Bool
(TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> Eq TypeFingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeFingerprint -> TypeFingerprint -> Bool
== :: TypeFingerprint -> TypeFingerprint -> Bool
$c/= :: TypeFingerprint -> TypeFingerprint -> Bool
/= :: TypeFingerprint -> TypeFingerprint -> Bool
Eq,
      Eq TypeFingerprint
Eq TypeFingerprint =>
(TypeFingerprint -> TypeFingerprint -> Ordering)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> Bool)
-> (TypeFingerprint -> TypeFingerprint -> TypeFingerprint)
-> (TypeFingerprint -> TypeFingerprint -> TypeFingerprint)
-> Ord 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
$ccompare :: TypeFingerprint -> TypeFingerprint -> Ordering
compare :: TypeFingerprint -> TypeFingerprint -> Ordering
$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
>= :: TypeFingerprint -> TypeFingerprint -> Bool
$cmax :: TypeFingerprint -> TypeFingerprint -> TypeFingerprint
max :: TypeFingerprint -> TypeFingerprint -> TypeFingerprint
$cmin :: TypeFingerprint -> TypeFingerprint -> TypeFingerprint
min :: TypeFingerprint -> TypeFingerprint -> TypeFingerprint
Ord
    )

instance Show TypeFingerprint where
  show :: TypeFingerprint -> String
show TypeableFingerprint {[Fingerprint]
TypeCategory
category :: TypeFingerprint -> TypeCategory
fingerprints :: TypeFingerprint -> [Fingerprint]
category :: TypeCategory
fingerprints :: [Fingerprint]
..} = String
"TYPEABLE:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (Text -> [Text] -> Text
intercalate Text
":" (String -> Text
pack (TypeCategory -> String
forall a. Show a => a -> String
show TypeCategory
category) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Fingerprint -> Text) -> [Fingerprint] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
pack (String -> Text) -> (Fingerprint -> String) -> Fingerprint -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> String
forall a. Show a => a -> String
show) [Fingerprint]
fingerprints))
  show (InternalFingerprint TypeName
name) = String
"INTERNAL:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName TypeName
name)
  show (CustomFingerprint TypeName
name) = String
"CUSTOM:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName TypeName
name)

instance Hashable TypeFingerprint where
  hashWithSalt :: Int -> TypeFingerprint -> Int
hashWithSalt Int
s TypeableFingerprint {[Fingerprint]
TypeCategory
category :: TypeFingerprint -> TypeCategory
fingerprints :: TypeFingerprint -> [Fingerprint]
category :: TypeCategory
fingerprints :: [Fingerprint]
..} = Int -> (Int, TypeCategory, [String]) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int
1 :: Int, TypeCategory
category, (Fingerprint -> String) -> [Fingerprint] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Fingerprint -> String
forall a. Show a => a -> String
show [Fingerprint]
fingerprints)
  hashWithSalt Int
s (InternalFingerprint TypeName
x) = Int -> (Int, TypeName) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int
2 :: Int, TypeName
x)
  hashWithSalt Int
s (CustomFingerprint TypeName
x) = Int -> (Int, TypeName) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int
3 :: Int, TypeName
x)

typeableTypename :: (Typeable a) => f a -> TypeName
typeableTypename :: forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> TypeName
typeableTypename = Text -> TypeName
forall a (t :: NAME). NamePacking a => a -> Name t
forall (t :: NAME). Text -> Name t
packName (Text -> TypeName) -> (f a -> Text) -> f a -> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
intercalate Text
"" ([Text] -> Text) -> (f a -> [Text]) -> f a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyCon -> Text) -> [TyCon] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
pack (String -> Text) -> (TyCon -> String) -> TyCon -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> String
tyConName (TyCon -> String) -> (TyCon -> TyCon) -> TyCon -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> TyCon
replacePairCon) ([TyCon] -> [Text]) -> (f a -> [TyCon]) -> f a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [TyCon]
forall {k} (a :: k) (f :: k -> *). Typeable a => f a -> [TyCon]
getTypeConstructors

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

typeableFingerprint :: (Typeable a) => CatType c a -> TypeFingerprint
typeableFingerprint :: forall {k} (a :: k) (c :: TypeCategory).
Typeable a =>
CatType c a -> TypeFingerprint
typeableFingerprint CatType c a
p =
  TypeableFingerprint
    { category :: TypeCategory
category = CatType c a -> TypeCategory
forall {k} (c :: TypeCategory) (a :: k).
CatType c a -> TypeCategory
toCategory CatType c a
p,
      fingerprints :: [Fingerprint]
fingerprints = TyCon -> Fingerprint
tyConFingerprint (TyCon -> Fingerprint) -> [TyCon] -> [Fingerprint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CatType c a -> [TyCon]
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 ((TyCon, [TypeRep]) -> [TyCon])
-> (f a -> (TyCon, [TypeRep])) -> f a -> [TyCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TyCon, [TypeRep])
splitTyConApp (TypeRep -> (TyCon, [TypeRep]))
-> (f a -> TypeRep) -> f a -> (TyCon, [TypeRep])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> TypeRep
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 (TypeRep -> TyCon) -> (f a -> TypeRep) -> f a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> TypeRep
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 | Proxy (Int, Int) -> TyCon
forall k (a :: k) (f :: k -> *). Typeable a => f a -> TyCon
rep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Int, Int)) TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
x = Proxy (Pair Int Int) -> TyCon
forall k (a :: k) (f :: k -> *). Typeable a => f a -> TyCon
rep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Pair Int Int))
replacePairCon TyCon
x = TyCon
x

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

-- ignores resolver names from typename
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver (TyCon
con, [TypeRep]
_) | TyCon
con TyCon -> [TyCon] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TyCon]
ignoredTypes = []
ignoreResolver (TyCon
con, [TypeRep]
args) = TyCon
con TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: (TypeRep -> [TyCon]) -> [TypeRep] -> [TyCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((TyCon, [TypeRep]) -> [TyCon]
ignoreResolver ((TyCon, [TypeRep]) -> [TyCon])
-> (TypeRep -> (TyCon, [TypeRep])) -> TypeRep -> [TyCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TyCon, [TypeRep])
splitTyConApp) [TypeRep]
args