{-# 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
      { category :: TypeCategory,
        fingerprints :: [Fingerprint]
      }
  | InternalFingerprint TypeName
  | CustomFingerprint TypeName
  deriving
    ( Generic,
      Eq,
      Ord
    )

instance Show TypeFingerprint where
  show TypeableFingerprint {..} = "TYPEABLE:" <> unpack (intercalate ":" (pack (show category) : map (pack . show) fingerprints))
  show (InternalFingerprint name) = "INTERNAL:" <> unpack (unpackName name)
  show (CustomFingerprint name) = "CUSTOM:" <> unpack (unpackName name)

instance Hashable TypeFingerprint where
  hashWithSalt s TypeableFingerprint {..} = hashWithSalt s (1 :: Int, category, map show fingerprints)
  hashWithSalt s (InternalFingerprint x) = hashWithSalt s (2 :: Int, x)
  hashWithSalt s (CustomFingerprint x) = hashWithSalt s (3 :: Int, x)

typeableTypename :: (Typeable a) => f a -> TypeName
typeableTypename = packName . intercalate "" . fmap (pack . tyConName . replacePairCon) . getTypeConstructors

toCategory :: CatType c a -> TypeCategory
toCategory InputType = IN
toCategory OutputType = OUT

typeableFingerprint :: (Typeable a) => CatType c a -> TypeFingerprint
typeableFingerprint p =
  TypeableFingerprint
    { category = toCategory p,
      fingerprints = tyConFingerprint <$> getTypeConstructors p
    }

getTypeConstructors :: (Typeable a) => f a -> [TyCon]
getTypeConstructors = ignoreResolver . splitTyConApp . typeRep

rep :: forall k (a :: k) f. (Typeable a) => f a -> TyCon
rep = typeRepTyCon . typeRep

-- | replaces typeName (A,B) with Pair_A_B
replacePairCon :: TyCon -> TyCon
replacePairCon x | rep (Proxy @(Int, Int)) == x = rep (Proxy @(Pair Int Int))
replacePairCon x = x

ignoredTypes :: [TyCon]
ignoredTypes =
  [ rep (Proxy @Resolver),
    rep (Proxy @NamedResolverT)
  ]

-- ignores resolver names from typename
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver (con, _) | con `elem` ignoredTypes = []
ignoreResolver (con, args) = con : concatMap (ignoreResolver . splitTyConApp) args
