Skip to content

Guaranteed correct name in AST #42

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 14 commits into from
Dec 30, 2016
Merged

Guaranteed correct name in AST #42

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
14 commits
Select commit Hold shift + click to select a range
d874d36
Ignore tutorial stack work
jml Dec 22, 2016
5eae1f7
Make AST.Name a protected type
jml Dec 22, 2016
f19e742
Admit possibility of failing names
jml Dec 22, 2016
a77d786
Do not panic when making schemas
jml Dec 22, 2016
f5f26fe
Rename getName to getNameText
jml Dec 22, 2016
e42254b
More error knowledge in AST
jml Dec 22, 2016
6373393
Type class for getting names
jml Dec 22, 2016
4d8c14d
Type class for HasArgumentDefinition
jml Dec 23, 2016
0e336b3
Make Int32 an annotated type
jml Dec 23, 2016
85d1b1d
Kill unsafeNameFromSymbol
jml Dec 23, 2016
b6a5d36
Throw query errors on unsafe names, rather than panic
jml Dec 23, 2016
f5fd20e
Remove spurious TODO
jml Dec 23, 2016
bfcac46
Fix broken doc test
jml Dec 23, 2016
307b56c
Fix indentation
jml Dec 23, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion .gitignore
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1 +1 @@
/.stack-work
.stack-work
165 changes: 100 additions & 65 deletions src/GraphQL/API.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,11 +16,13 @@ module GraphQL.API
, GraphQLEnum(..)
, Interface
, (:>)(..)
, HasAnnotatedType(..)
, HasAnnotatedInputType
, HasObjectDefinition(..)
, getArgumentDefinition
-- | Exported for testing. Perhaps should be a different module.
, getFieldDefinition
, getDefinition
, getInterfaceDefinition
, getAnnotatedType
, getAnnotatedInputType
) where

Expand All @@ -31,6 +33,7 @@ import qualified GraphQL.Internal.Schema (Type)
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import qualified GHC.TypeLits (TypeError, ErrorMessage(..))
import qualified GraphQL.Value as GValue
import GraphQL.Internal.AST (NameError, makeName)

-- $setup
-- >>> :set -XDataKinds -XTypeOperators
Expand Down Expand Up @@ -78,25 +81,31 @@ data Argument (name :: Symbol) (argType :: Type)
-- https://hackage.haskell.org/package/optional-args-1.0.1)
data DefaultArgument (name :: Symbol) (argType :: Type)

-- | Convert a type-level 'Symbol' into a GraphQL 'Name'.
nameFromSymbol :: forall (n :: Symbol) (proxy :: Symbol -> *). KnownSymbol n => proxy n -> Either NameError Name
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

if you feel adventurous you could use type application here as well for consistency with the rest of our APIs. I.e.: nameFromSymbol @name

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I felt a little bit adventurous and tried this earlier, but couldn't figure it out in the time I had allotted.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

ack, if you add a todo I'll do it

nameFromSymbol proxy = makeName (toS (symbolVal proxy))

cons :: a -> [a] -> [a]
cons = (:)

-- Transform into a Schema definition
class HasObjectDefinition a where
-- Todo rename to getObjectTypeDefinition
getDefinition :: ObjectTypeDefinition
getDefinition :: Either NameError ObjectTypeDefinition

class HasFieldDefinition a where
getFieldDefinition :: FieldDefinition
getFieldDefinition :: Either NameError FieldDefinition


-- Fields
class HasFieldDefinitions a where
getFieldDefinitions :: [FieldDefinition]
getFieldDefinitions :: Either NameError [FieldDefinition]

instance forall a as. (HasFieldDefinition a, HasFieldDefinitions as) => HasFieldDefinitions (a:as) where
getFieldDefinitions = (getFieldDefinition @a):(getFieldDefinitions @as)
getFieldDefinitions = cons <$> getFieldDefinition @a <*> getFieldDefinitions @as

instance HasFieldDefinitions '[] where
getFieldDefinitions = []
getFieldDefinitions = pure []

-- | For each enum type we need 1) a list of all possible values 2) a
-- way to serialise and 3) deserialise.
Expand All @@ -110,38 +119,32 @@ class GraphQLEnum a where
-- Union "Horse" '[Leg, Head, Tail]
-- ^^^^^^^^^^^^^^^^^^ this part
class UnionTypeObjectTypeDefinitionList a where
getUnionTypeObjectTypeDefinitions :: [ObjectTypeDefinition]
getUnionTypeObjectTypeDefinitions :: Either NameError [ObjectTypeDefinition]

instance forall a as. (HasObjectDefinition a, UnionTypeObjectTypeDefinitionList as) => UnionTypeObjectTypeDefinitionList (a:as) where
getUnionTypeObjectTypeDefinitions = (getDefinition @a):(getUnionTypeObjectTypeDefinitions @as)
getUnionTypeObjectTypeDefinitions = cons <$> getDefinition @a <*> getUnionTypeObjectTypeDefinitions @as

instance UnionTypeObjectTypeDefinitionList '[] where
getUnionTypeObjectTypeDefinitions = []


-- | Convert a type-level 'Symbol' into a GraphQL 'Name'.
--
-- Panics if the name is not valid GraphQL.
unsafeNameFromSymbol :: forall (n :: Symbol) (proxy :: Symbol -> *). KnownSymbol n => proxy n -> Name
unsafeNameFromSymbol = GValue.unsafeMakeName . toS . symbolVal
getUnionTypeObjectTypeDefinitions = pure []

-- Interfaces
class HasInterfaceDefinitions a where
getInterfaceDefinitions :: Interfaces
getInterfaceDefinitions :: Either NameError Interfaces

instance forall a as. (HasInterfaceDefinition a, HasInterfaceDefinitions as) => HasInterfaceDefinitions (a:as) where
getInterfaceDefinitions = getInterfaceDefinition @a:getInterfaceDefinitions @as
getInterfaceDefinitions = cons <$> getInterfaceDefinition @a <*> getInterfaceDefinitions @as

instance HasInterfaceDefinitions '[] where
getInterfaceDefinitions = []
getInterfaceDefinitions = pure []

class HasInterfaceDefinition a where
getInterfaceDefinition :: InterfaceTypeDefinition
getInterfaceDefinition :: Either NameError InterfaceTypeDefinition

instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where
getInterfaceDefinition =
let name = unsafeNameFromSymbol (Proxy :: Proxy ks)
in InterfaceTypeDefinition name (NonEmptyList (getFieldDefinitions @fields))
let name = nameFromSymbol (Proxy :: Proxy ks)
fields = NonEmptyList <$> getFieldDefinitions @fields
in InterfaceTypeDefinition <$> name <*> fields

-- Give users some help if they don't terminate Arguments with a Field:
-- NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099
Expand All @@ -152,28 +155,38 @@ instance forall ks t. GHC.TypeLits.TypeError ('GHC.TypeLits.Text ":> Arguments m
instance forall ks is ts. (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions ts) => HasAnnotatedType (Object ks is ts) where
getAnnotatedType =
let obj = getDefinition @(Object ks is ts)
in (TypeNamed . DefinedType . TypeDefinitionObject) obj
in (TypeNamed . DefinedType . TypeDefinitionObject) <$> obj

instance forall t ks. (KnownSymbol ks, HasAnnotatedType t) => HasFieldDefinition (Field ks t) where
getFieldDefinition =
let name = unsafeNameFromSymbol (Proxy :: Proxy ks)
in FieldDefinition name [] (getAnnotatedType @t)
let name = nameFromSymbol (Proxy :: Proxy ks)
in FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t

class HasArgumentDefinition a where
getArgumentDefinition :: Either NameError ArgumentDefinition

instance forall ks t b. (KnownSymbol ks, HasAnnotatedInputType t, HasFieldDefinition b) => HasFieldDefinition (Argument ks t :> b) where
getFieldDefinition =
let (FieldDefinition name argDefs at) = getFieldDefinition @b
argName = unsafeNameFromSymbol (Proxy :: Proxy ks)
arg = ArgumentDefinition argName (getAnnotatedInputType @t) Nothing
in FieldDefinition name (arg:argDefs) at
instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where
getArgumentDefinition = ArgumentDefinition <$> argName <*> argType <*> defaultValue
where
argName = nameFromSymbol (Proxy :: Proxy ks)
argType = getAnnotatedInputType @t
defaultValue = pure Nothing

instance forall a b. (HasArgumentDefinition a, HasFieldDefinition b) => HasFieldDefinition (a :> b) where
getFieldDefinition =
prependArg <$> argument <*> getFieldDefinition @b
where
prependArg arg (FieldDefinition name argDefs at) = FieldDefinition name (arg:argDefs) at
argument = getArgumentDefinition @a

instance forall ks is fields.
(KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions fields) =>
HasObjectDefinition (Object ks is fields) where
getDefinition =
let name = unsafeNameFromSymbol (Proxy :: Proxy ks)
in ObjectTypeDefinition name (getInterfaceDefinitions @is) (NonEmptyList (getFieldDefinitions @fields))
let name = nameFromSymbol (Proxy :: Proxy ks)
interfaces = getInterfaceDefinitions @is
fields = NonEmptyList <$> getFieldDefinitions @fields
in ObjectTypeDefinition <$> name <*> interfaces <*> fields

-- Builtin output types (annotated types)
class HasAnnotatedType a where
Expand All @@ -182,43 +195,61 @@ class HasAnnotatedType a where
-- forget this. Maybe we can flip the internal encoding to be
-- non-null by default and needing explicit null-encoding (via
-- Maybe).
getAnnotatedType :: AnnotatedType GraphQL.Internal.Schema.Type
getAnnotatedType :: Either NameError (AnnotatedType GraphQL.Internal.Schema.Type)

-- | Turn a non-null type into the optional version of its own type.
dropNonNull :: AnnotatedType t -> AnnotatedType t
dropNonNull (TypeNonNull (NonNullTypeNamed t)) = TypeNamed t
dropNonNull (TypeNonNull (NonNullTypeList t)) = TypeList t
dropNonNull x@(TypeNamed _) = x
dropNonNull x@(TypeList _) = x

instance forall a. HasAnnotatedType a => HasAnnotatedType (Maybe a) where
-- see TODO in HasAnnotatedType class
getAnnotatedType =
let TypeNonNull (NonNullTypeNamed t) = getAnnotatedType @a
in TypeNamed t
getAnnotatedType = dropNonNull <$> getAnnotatedType @a

builtinType :: Builtin -> Either NameError (AnnotatedType GraphQL.Internal.Schema.Type)
builtinType = pure . TypeNonNull . NonNullTypeNamed . BuiltinType

-- TODO(jml): Given that AnnotatedType is parametrised, we can probably reduce
-- a great deal of duplication by making HasAnnotatedType a parametrised type
-- class.

-- TODO(jml): Be smarter and figure out how to say "all integral types" rather
-- than listing each individually.

instance HasAnnotatedType Int where
getAnnotatedType = (TypeNonNull . NonNullTypeNamed . BuiltinType) GInt
getAnnotatedType = builtinType GInt

instance HasAnnotatedType Int32 where
getAnnotatedType = builtinType GInt

instance HasAnnotatedType Bool where
getAnnotatedType = (TypeNonNull . NonNullTypeNamed . BuiltinType) GBool
getAnnotatedType = builtinType GBool

instance HasAnnotatedType Text where
getAnnotatedType = (TypeNonNull . NonNullTypeNamed . BuiltinType) GString
getAnnotatedType = builtinType GString

instance HasAnnotatedType Double where
getAnnotatedType = (TypeNonNull . NonNullTypeNamed . BuiltinType) GFloat
getAnnotatedType = builtinType GFloat

instance HasAnnotatedType Float where
getAnnotatedType = (TypeNonNull . NonNullTypeNamed . BuiltinType) GFloat
getAnnotatedType = builtinType GFloat

instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where
getAnnotatedType = TypeList (ListType (getAnnotatedType @t))
getAnnotatedType = TypeList . ListType <$> getAnnotatedType @t

instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedType (Enum ks enum) where
getAnnotatedType =
let name = unsafeNameFromSymbol (Proxy :: Proxy ks)
et = EnumTypeDefinition name (map EnumValueDefinition (enumValues @enum))
in TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum et)))
getAnnotatedType = do
let name = nameFromSymbol (Proxy :: Proxy ks)
let et = EnumTypeDefinition <$> name <*> pure (map EnumValueDefinition (enumValues @enum))
TypeNonNull . NonNullTypeNamed . DefinedType . TypeDefinitionEnum <$> et

instance forall ks as. (KnownSymbol ks, UnionTypeObjectTypeDefinitionList as) => HasAnnotatedType (Union ks as) where
getAnnotatedType =
let name = unsafeNameFromSymbol (Proxy :: Proxy ks)
types = NonEmptyList (getUnionTypeObjectTypeDefinitions @as)
in TypeNamed (DefinedType (TypeDefinitionUnion (UnionTypeDefinition name types)))
let name = nameFromSymbol (Proxy :: Proxy ks)
types = NonEmptyList <$> getUnionTypeObjectTypeDefinitions @as
in (TypeNamed . DefinedType . TypeDefinitionUnion) <$> (UnionTypeDefinition <$> name <*> types)

-- Help users with better type errors
instance GHC.TypeLits.TypeError ('GHC.TypeLits.Text "Cannot encode Integer because it has arbitrary size but the JSON encoding is a number") =>
Expand All @@ -229,33 +260,37 @@ instance GHC.TypeLits.TypeError ('GHC.TypeLits.Text "Cannot encode Integer becau
-- Builtin input types
class HasAnnotatedInputType a where
-- See TODO comment in "HasAnnotatedType" class for nullability.
getAnnotatedInputType :: AnnotatedType InputType
getAnnotatedInputType :: Either NameError (AnnotatedType InputType)

instance forall a. HasAnnotatedInputType a => HasAnnotatedInputType (Maybe a) where
getAnnotatedInputType =
let TypeNonNull (NonNullTypeNamed t) = getAnnotatedInputType @a
in TypeNamed t
getAnnotatedInputType = dropNonNull <$> getAnnotatedInputType @a

builtinInputType :: Builtin -> Either NameError (AnnotatedType InputType)
builtinInputType = pure . TypeNonNull . NonNullTypeNamed . BuiltinInputType

instance HasAnnotatedInputType Int where
getAnnotatedInputType = (TypeNonNull . NonNullTypeNamed . BuiltinInputType) GInt
getAnnotatedInputType = builtinInputType GInt

instance HasAnnotatedInputType Int32 where
getAnnotatedInputType = builtinInputType GInt

instance HasAnnotatedInputType Bool where
getAnnotatedInputType = (TypeNonNull . NonNullTypeNamed . BuiltinInputType) GBool
getAnnotatedInputType = builtinInputType GBool

instance HasAnnotatedInputType Text where
getAnnotatedInputType = (TypeNonNull . NonNullTypeNamed . BuiltinInputType) GString
getAnnotatedInputType = builtinInputType GString

instance HasAnnotatedInputType Double where
getAnnotatedInputType = (TypeNonNull . NonNullTypeNamed . BuiltinInputType) GFloat
getAnnotatedInputType = builtinInputType GFloat

instance HasAnnotatedInputType Float where
getAnnotatedInputType = (TypeNonNull . NonNullTypeNamed . BuiltinInputType) GFloat
getAnnotatedInputType = builtinInputType GFloat

instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where
getAnnotatedInputType = TypeList (ListType (getAnnotatedInputType @t))
getAnnotatedInputType = TypeList . ListType <$> getAnnotatedInputType @t

instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedInputType (Enum ks enum) where
getAnnotatedInputType =
let name = unsafeNameFromSymbol (Proxy :: Proxy ks)
et = EnumTypeDefinition name (map EnumValueDefinition (enumValues @enum))
in TypeNonNull (NonNullTypeNamed (DefinedInputType (InputTypeDefinitionEnum et)))
getAnnotatedInputType = do
let name = nameFromSymbol (Proxy :: Proxy ks)
let et = EnumTypeDefinition <$> name <*> pure (map EnumValueDefinition (enumValues @enum))
TypeNonNull . NonNullTypeNamed . DefinedInputType . InputTypeDefinitionEnum <$> et
Loading