{-# 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 {forall (t :: NAME). Name t -> Text _unpackName :: Text} deriving (forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall (t :: NAME) x. Rep (Name t) x -> Name t forall (t :: NAME) x. Name t -> Rep (Name t) x $cto :: forall (t :: NAME) x. Rep (Name t) x -> Name t $cfrom :: forall (t :: NAME) x. Name t -> Rep (Name t) x Generic) deriving newtype ( Int -> Name t -> ShowS [Name t] -> ShowS Name t -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a forall (t :: NAME). Int -> Name t -> ShowS forall (t :: NAME). [Name t] -> ShowS forall (t :: NAME). Name t -> String showList :: [Name t] -> ShowS $cshowList :: forall (t :: NAME). [Name t] -> ShowS show :: Name t -> String $cshow :: forall (t :: NAME). Name t -> String showsPrec :: Int -> Name t -> ShowS $cshowsPrec :: forall (t :: NAME). Int -> Name t -> ShowS Show, Name t -> Name t -> Bool Name t -> Name t -> Ordering Name t -> Name t -> Name t 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 forall (t :: NAME). Eq (Name t) forall (t :: NAME). Name t -> Name t -> Bool forall (t :: NAME). Name t -> Name t -> Ordering forall (t :: NAME). Name t -> Name t -> Name t min :: Name t -> Name t -> Name t $cmin :: forall (t :: NAME). Name t -> Name t -> Name t max :: Name t -> Name t -> Name t $cmax :: forall (t :: NAME). Name t -> Name t -> Name t >= :: Name t -> Name t -> Bool $c>= :: forall (t :: NAME). Name t -> Name t -> Bool > :: Name t -> Name t -> Bool $c> :: forall (t :: NAME). Name t -> Name t -> Bool <= :: Name t -> Name t -> Bool $c<= :: forall (t :: NAME). Name t -> Name t -> Bool < :: Name t -> Name t -> Bool $c< :: forall (t :: NAME). Name t -> Name t -> Bool compare :: Name t -> Name t -> Ordering $ccompare :: forall (t :: NAME). Name t -> Name t -> Ordering Ord, Name t -> Name t -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a forall (t :: NAME). Name t -> Name t -> Bool /= :: Name t -> Name t -> Bool $c/= :: forall (t :: NAME). Name t -> Name t -> Bool == :: Name t -> Name t -> Bool $c== :: forall (t :: NAME). Name t -> Name t -> Bool Eq, String -> Name t forall a. (String -> a) -> IsString a forall (t :: NAME). String -> Name t fromString :: String -> Name t $cfromString :: forall (t :: NAME). String -> Name t IsString, Name t -> String forall a. (a -> String) -> ToString a forall (t :: NAME). Name t -> String toString :: Name t -> String $ctoString :: forall (t :: NAME). Name t -> String ToString, Int -> Name t -> Int Name t -> Int forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a forall (t :: NAME). Eq (Name t) forall (t :: NAME). Int -> Name t -> Int forall (t :: NAME). Name t -> Int hash :: Name t -> Int $chash :: forall (t :: NAME). Name t -> Int hashWithSalt :: Int -> Name t -> Int $chashWithSalt :: forall (t :: NAME). Int -> Name t -> Int Hashable, NonEmpty (Name t) -> Name t Name t -> Name t -> Name t forall b. Integral b => b -> Name t -> Name t forall a. (a -> a -> a) -> (NonEmpty a -> a) -> (forall b. Integral b => b -> a -> a) -> Semigroup a forall (t :: NAME). NonEmpty (Name t) -> Name t forall (t :: NAME). Name t -> Name t -> Name t forall (t :: NAME) b. Integral b => b -> Name t -> Name t stimes :: forall b. Integral b => b -> Name t -> Name t $cstimes :: forall (t :: NAME) b. Integral b => b -> Name t -> Name t sconcat :: NonEmpty (Name t) -> Name t $csconcat :: forall (t :: NAME). NonEmpty (Name t) -> Name t <> :: Name t -> Name t -> Name t $c<> :: forall (t :: NAME). Name t -> Name t -> Name t Semigroup, Value -> Parser [Name t] Value -> Parser (Name t) forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a forall (t :: NAME). Value -> Parser [Name t] forall (t :: NAME). Value -> Parser (Name t) parseJSONList :: Value -> Parser [Name t] $cparseJSONList :: forall (t :: NAME). Value -> Parser [Name t] parseJSON :: Value -> Parser (Name t) $cparseJSON :: forall (t :: NAME). Value -> Parser (Name t) FromJSON, [Name t] -> Encoding [Name t] -> Value Name t -> Encoding Name t -> Value forall a. (a -> Value) -> (a -> Encoding) -> ([a] -> Value) -> ([a] -> Encoding) -> ToJSON a forall (t :: NAME). [Name t] -> Encoding forall (t :: NAME). [Name t] -> Value forall (t :: NAME). Name t -> Encoding forall (t :: NAME). Name t -> Value toEncodingList :: [Name t] -> Encoding $ctoEncodingList :: forall (t :: NAME). [Name t] -> Encoding toJSONList :: [Name t] -> Value $ctoJSONList :: forall (t :: NAME). [Name t] -> Value toEncoding :: Name t -> Encoding $ctoEncoding :: forall (t :: NAME). Name t -> Encoding toJSON :: Name t -> Value $ctoJSON :: forall (t :: NAME). Name t -> Value ToJSON ) instance Msg (Name t) where msg :: Name t -> GQLError msg Name t name = forall a. Msg a => a -> GQLError msg forall a b. (a -> b) -> a -> b $ Text "\"" forall a. Semigroup a => a -> a -> a <> forall (t :: NAME). Name t -> Text _unpackName Name t name forall a. Semigroup a => a -> a -> a <> Text "\"" isValidName :: Name t -> Bool isValidName :: forall (t :: NAME). Name t -> Bool isValidName Name t n = (Char -> Bool) -> Text -> Bool T.all Char -> Bool isStart (Int -> Text -> Text T.take Int 1 Text name) Bool -> Bool -> Bool && (Char -> Bool) -> Text -> Bool T.all Char -> Bool isContinue (Int -> Text -> Text T.drop Int 1 Text name) where name :: Text name = forall a (t :: NAME). NamePacking a => Name t -> a unpackName Name t n isStart :: Char -> Bool isStart Char c = Char c forall a. Eq a => a -> a -> Bool == Char '_' Bool -> Bool -> Bool || Char -> Bool isLetter Char c isContinue :: Char -> Bool isContinue Char c = Char -> Bool isStart Char c Bool -> Bool -> Bool || Char -> Bool isNumber Char c class NamePacking a where packName :: a -> Name t unpackName :: Name t -> a instance NamePacking TH.Name where packName :: forall (t :: NAME). Name -> Name t packName (TH.Name OccName name NameFlavour _) = forall (t :: NAME). Text -> Name t Name forall a b. (a -> b) -> a -> b $ String -> Text T.pack (OccName -> String occName OccName name) where occName :: OccName -> String occName (TH.OccName String x) = forall b a. b -> (a -> b) -> Maybe a -> b maybe String x (forall a. (a -> Bool) -> [a] -> [a] takeWhile (forall a. Eq a => a -> a -> Bool /= Char ':')) (forall a. Eq a => [a] -> [a] -> Maybe [a] L.stripPrefix String "$sel:" String x) unpackName :: forall (t :: NAME). Name t -> Name unpackName = String -> Name TH.mkName forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. ToString a => a -> String toString forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: NAME). Name t -> Text _unpackName instance NamePacking Text where packName :: forall (t :: NAME). Text -> Name t packName = forall (t :: NAME). Text -> Name t Name unpackName :: forall (t :: NAME). Name t -> Text unpackName = forall (t :: NAME). Name t -> Text _unpackName #if MIN_VERSION_aeson(2,0,0) instance NamePacking Key where packName :: forall (t :: NAME). Key -> Name t packName = forall (t :: NAME). Text -> Name t Name forall b c a. (b -> c) -> (a -> b) -> a -> c . Key -> Text A.toText unpackName :: forall (t :: NAME). Name t -> Key unpackName = Text -> Key A.fromText forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: NAME). Name t -> Text _unpackName #endif instance Lift (Name t) where lift :: forall (m :: * -> *). Quote m => Name t -> m Exp lift = forall (m :: * -> *). Quote m => String -> m Exp stringE forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> String T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a (t :: NAME). NamePacking a => Name t -> a unpackName #if MIN_VERSION_template_haskell(2,17,0) liftTyped :: forall (m :: * -> *). Quote m => Name t -> Code m (Name t) liftTyped = forall (m :: * -> *) (t :: NAME). Quote m => Text -> Code m (Name t) liftTypedString forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a (t :: NAME). NamePacking a => Name t -> a unpackName where liftTypedString :: (Quote m) => Text -> Code m (Name t) liftTypedString :: forall (m :: * -> *) (t :: NAME). Quote m => Text -> Code m (Name t) liftTypedString = forall a (m :: * -> *). Quote m => m Exp -> Code m a unsafeCodeCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). Quote m => String -> m Exp stringE forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> String 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 :: Name a -> Rendering renderGQL = Text -> Rendering fromText forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a (t :: NAME). NamePacking a => Name t -> a unpackName type FieldName = Name 'FIELD type TypeName = Name 'TYPE type FragmentName = Name 'FRAGMENT intercalate :: Name t1 -> [Name t2] -> Name t3 intercalate :: forall (t1 :: NAME) (t2 :: NAME) (t3 :: NAME). Name t1 -> [Name t2] -> Name t3 intercalate (Name Text x) = forall (t :: NAME). Text -> Name t Name forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> [Text] -> Text T.intercalate Text x forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a (t :: NAME). NamePacking a => Name t -> a unpackName {-# INLINE intercalate #-} unitTypeName :: TypeName unitTypeName :: TypeName unitTypeName = TypeName "Unit" {-# INLINE unitTypeName #-} unitFieldName :: FieldName unitFieldName :: FieldName unitFieldName = FieldName "_" {-# INLINE unitFieldName #-} isNotSystemTypeName :: TypeName -> Bool isNotSystemTypeName :: TypeName -> Bool isNotSystemTypeName = ( forall (f :: * -> *) a. (Foldable f, DisallowElem f, Eq a) => a -> f a -> Bool `notElem` [ TypeName "__Schema", TypeName "__Type", TypeName "__Directive", TypeName "__TypeKind", TypeName "__Field", TypeName "__DirectiveLocation", TypeName "__InputValue", TypeName "__EnumValue", TypeName "String", TypeName "Float", TypeName "Int", TypeName "Boolean", TypeName "ID" ] ) {-# INLINE isNotSystemTypeName #-} isNotSystemFieldName :: FieldName -> Bool isNotSystemFieldName :: FieldName -> Bool isNotSystemFieldName = ( forall (f :: * -> *) a. (Foldable f, DisallowElem f, Eq a) => a -> f a -> Bool `notElem` [ FieldName "__typename", FieldName "__schema", FieldName "__type" ] ) {-# INLINE isNotSystemFieldName #-}