{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.AST.Name
  ( Name,
    packName,
    unpackName,
    FieldName,
    TypeName,
    unitTypeName,
    unitFieldName,
    isNotSystemTypeName,
    isNotSystemFieldName,
    intercalate,
    NAME (..),
    FragmentName,
    isValidName,
  )
where

import Data.Aeson
  ( FromJSON,
    ToJSON (..),
  )
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.Key (Key)
import qualified Data.Aeson.Key as A
#endif

#if MIN_VERSION_template_haskell(2,17,0)
import Language.Haskell.TH
  ( Quote,
    Code,
    unsafeCodeCoerce,
    stringE
  )
import Language.Haskell.TH.Syntax(
    Lift(..)
  )
# else
import Language.Haskell.TH
  ( stringE,
  )
import Language.Haskell.TH.Syntax
  ( Lift (..),
    Q,
    TExp,
    unsafeTExpCoerce,
  )
#endif
import Data.Char (isLetter, isNumber)
import qualified Data.List as L
import Data.Morpheus.Rendering.RenderGQL
  ( RenderGQL (..),
    fromText,
    renderGQL,
  )
import Data.Morpheus.Types.Internal.AST.Error
  ( Msg (..),
  )
import qualified Data.Text as T
import qualified Language.Haskell.TH.Syntax as TH
import Relude hiding
  ( ByteString,
    decodeUtf8,
    intercalate,
  )

data NAME
  = TYPE
  | FIELD
  | FRAGMENT

newtype Name (t :: NAME) = Name {_unpackName :: Text}
  deriving
    (Generic)
  deriving newtype
    ( Show,
      Ord,
      Eq,
      IsString,
      ToString,
      Hashable,
      Semigroup,
      FromJSON,
      ToJSON
    )

instance Msg (Name t) where
  msg name = msg $ "\"" <> _unpackName name <> "\""

isValidName :: Name t -> Bool
isValidName n = T.all isStart (T.take 1 name) && T.all isContinue (T.drop 1 name)
  where
    name = unpackName n
    isStart c = c == '_' || isLetter c
    isContinue c = isStart c || isNumber c

class NamePacking a where
  packName :: a -> Name t
  unpackName :: Name t -> a

instance NamePacking TH.Name where
  packName (TH.Name name _) = Name $ T.pack (occName name)
    where
      occName (TH.OccName x) = maybe x (takeWhile (/= ':')) (L.stripPrefix "$sel:" x)
  unpackName = TH.mkName . toString . _unpackName

instance NamePacking Text where
  packName = Name
  unpackName = _unpackName

#if MIN_VERSION_aeson(2,0,0)
instance NamePacking Key where
  packName = Name . A.toText
  unpackName = A.fromText . _unpackName
#endif

instance Lift (Name t) where
  lift = stringE . T.unpack . unpackName

#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped = liftTypedString . unpackName
    where
      liftTypedString :: (Quote m) => Text -> Code m (Name t)
      liftTypedString = unsafeCodeCoerce . stringE . T.unpack
      {-# INLINE liftTypedString #-}
#elif MIN_VERSION_template_haskell(2,16,0)
  liftTyped = liftTypedString . unpackName
    where
      liftTypedString :: IsString a => Text -> Q (TExp a)
      liftTypedString = unsafeTExpCoerce . stringE . T.unpack
      {-# INLINE liftTypedString #-}
#endif

instance RenderGQL (Name a) where
  renderGQL = fromText . unpackName

type FieldName = Name 'FIELD

type TypeName = Name 'TYPE

type FragmentName = Name 'FRAGMENT

intercalate :: Name t1 -> [Name t2] -> Name t3
intercalate (Name x) = Name . T.intercalate x . fmap unpackName
{-# INLINE intercalate #-}

unitTypeName :: TypeName
unitTypeName = "Unit"
{-# INLINE unitTypeName #-}

unitFieldName :: FieldName
unitFieldName = "_"
{-# INLINE unitFieldName #-}

isNotSystemTypeName :: TypeName -> Bool
isNotSystemTypeName =
  ( `notElem`
      [ "__Schema",
        "__Type",
        "__Directive",
        "__TypeKind",
        "__Field",
        "__DirectiveLocation",
        "__InputValue",
        "__EnumValue",
        "String",
        "Float",
        "Int",
        "Boolean",
        "ID"
      ]
  )
{-# INLINE isNotSystemTypeName #-}

isNotSystemFieldName :: FieldName -> Bool
isNotSystemFieldName =
  ( `notElem`
      [ "__typename",
        "__schema",
        "__type"
      ]
  )
{-# INLINE isNotSystemFieldName #-}