module GraphQL.API.Enum
( GraphQLEnum(..)
) where
import Protolude hiding (Enum, TypeError)
import GraphQL.Internal.Name (Name, nameFromSymbol, NameError)
import GraphQL.Internal.Output (GraphQLError(..))
import GHC.Generics (D, (:+:)(..))
import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..))
invalidEnumName :: forall t. NameError -> Either Text t
invalidEnumName x = Left ("In Enum: " <> formatError x)
class GenericEnumValues (f :: Type -> Type) where
genericEnumValues :: [Either NameError Name]
genericEnumFromValue :: Name -> Either Text (f p)
genericEnumToValue :: f p -> Name
instance forall conName m p f nt.
( KnownSymbol conName
, KnownSymbol m
, KnownSymbol p
, GenericEnumValues f
) => GenericEnumValues (M1 D ('MetaData conName m p nt) f) where
genericEnumValues = genericEnumValues @f
genericEnumFromValue name = M1 <$> genericEnumFromValue name
genericEnumToValue (M1 gv) = genericEnumToValue gv
instance forall conName f p b.
( KnownSymbol conName
, GenericEnumValues f
) => GenericEnumValues (C1 ('MetaCons conName p b) U1 :+: f) where
genericEnumValues = let name = nameFromSymbol @conName in name:genericEnumValues @f
genericEnumFromValue vname =
case nameFromSymbol @conName of
Right name -> if name == vname
then L1 <$> Right (M1 U1)
else R1 <$> genericEnumFromValue vname
Left x -> invalidEnumName x
genericEnumToValue (L1 _) =
case nameFromSymbol @conName of
Right name -> name
Left err -> panic ("Invalid name: " <> show err <> ". This should have been caught during validation. Please file a bug.")
genericEnumToValue (R1 gv) = genericEnumToValue gv
instance forall conName p b. (KnownSymbol conName) => GenericEnumValues (C1 ('MetaCons conName p b) U1) where
genericEnumValues = let name = nameFromSymbol @conName in [name]
genericEnumFromValue vname =
case nameFromSymbol @conName of
Right name -> if name == vname
then Right (M1 U1)
else Left ("Not a valid choice for enum: " <> show vname)
Left x -> invalidEnumName x
genericEnumToValue (M1 _) =
let Right name = nameFromSymbol @conName
in name
instance forall conName p b sa sb.
( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName)
, KnownSymbol conName
) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb)) where
genericEnumValues = undefined
genericEnumFromValue = undefined
genericEnumToValue = undefined
instance forall conName p b sa sb f.
( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName)
, KnownSymbol conName
) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb) :+: f) where
genericEnumValues = undefined
genericEnumFromValue = undefined
genericEnumToValue = undefined
class GraphQLEnum a where
enumValues :: [Either NameError Name]
default enumValues :: (Generic a, GenericEnumValues (Rep a)) => [Either NameError Name]
enumValues = genericEnumValues @(Rep a)
enumFromValue :: Name -> Either Text a
default enumFromValue :: (Generic a, GenericEnumValues (Rep a)) => Name -> Either Text a
enumFromValue v = to <$> genericEnumFromValue v
enumToValue :: a -> Name
default enumToValue :: (Generic a, GenericEnumValues (Rep a)) => a -> Name
enumToValue = genericEnumToValue . from