Make introspection work with new graphiql verison

source/AirGQL/Introspection.hs

@@ -12,7 +12,6 @@ import Protolude (
   Monoid (mempty),
   Semigroup ((<>)),
   Text,
-  fromMaybe,
   ($),
   (&),
   (<&>),
@@ -58,7 +57,10 @@ typeNameResolver =
 
 
 columnTypeName :: ColumnEntry -> Text
-columnTypeName entry = fromMaybe "String" (columnType entry).name
+columnTypeName entry =
+  case entry.datatype_gql of
+    Nothing -> "String"
+    Just type_ -> type_.full
 
 
 columnType :: ColumnEntry -> IntrospectionType
@@ -284,7 +286,7 @@ tableUpdateField accessMode table = do
     & Type.withArguments
       [ Type.inputValue
           "set"
-          (Type.nonNull $ Type.nonNull updateRow)
+          (Type.nonNull updateRow)
           & Type.inputValueWithDescription "Fields to be updated"
       , Type.inputValue
           "filter"

source/AirGQL/Introspection/Resolver.hs

@@ -1,4 +1,4 @@
-module AirGQL.Introspection.Resolver (makeType, makeConstField, makeChildField) where
+module AirGQL.Introspection.Resolver (makeType, makeConstField) where
 
 import Protolude (
   Either (Left),
@@ -8,8 +8,8 @@ import Protolude (
   Text,
   fromMaybe,
   mempty,
-  note,
   pure,
+  show,
   ($),
   (+),
   (<$>),
@@ -29,150 +29,144 @@ import Language.GraphQL.Type.Out qualified as Out
 type Result = Either Text
 
 
-maxDepth :: Int
-maxDepth = 9
-
-
 makeType :: IType.IntrospectionType -> Result (Out.Type IO)
-makeType = makeTypeWithDepth 0
+makeType =
+  let
+    -- This is the same as `makeTypeWithDepth`, except the outputs
+    -- for `__Type` are memoized.
+    --
+    -- This turns the memory usage from O(C^n) to O(n), where n is the depth.
+    -- This greatly speeds up introspection from the playground, which requires
+    -- a depth of around 10 (from what I can recall).
+    makeTypeWithDepthMemo :: Int -> IType.IntrospectionType -> Result (Out.Type IO)
+    makeTypeWithDepthMemo depth ty = case ty.kind of
+      IType.Object "__Type" _ ->
+        P.join $ P.note "(impossible)" $ P.atMay typeCache depth
+      _ -> makeTypeWithDepth depth ty
 
+    -- The memoization is done using a haskell lazy array.
+    typeCache = [makeTypeWithDepth i IType.typeIntrospectionType | i <- [0 ..]]
 
-makeTypeWithDepth :: Int -> IType.IntrospectionType -> Result (Out.Type IO)
+    makeTypeWithDepth :: Int -> IType.IntrospectionType -> Result (Out.Type IO)
-makeTypeWithDepth depth ty = do
+    makeTypeWithDepth depth ty =
-  case ty.kind of
+      case ty.kind of
-    IType.Scalar -> do
+        IType.Scalar name -> do
-      name <- note "No `name` found for scalar" ty.name
+          pure $ Out.NamedScalarType $ Type.ScalarType name ty.description
-      pure $ Out.NamedScalarType $ Type.ScalarType name ty.description
+        IType.List ofType -> do
-    IType.List -> do
+          Out.ListType <$> makeTypeWithDepthMemo depth ofType
-      ofType <- note "No `ofType` found for list" ty.ofType
+        IType.Enum name enumValues -> do
-      Out.ListType <$> makeTypeWithDepth depth ofType
+          let variants =
-    IType.Enum -> do
+                enumValues
-      name <- note "No `name` found for enum" ty.name
+                  <&> \variant -> (variant.name, Type.EnumValue variant.description)
-      enumValues <- note "No `enumValues` found for enum" ty.enumValues
+          pure $
-      let variants = enumValues <&> \variant -> (variant.name, Type.EnumValue variant.description)
+            Out.NamedEnumType $
-      pure $
+              Type.EnumType name ty.description $
-        Out.NamedEnumType $
+                HashMap.fromList variants
-          Type.EnumType name ty.description $
+        IType.NonNull ofType -> do
-            HashMap.fromList variants
+          inner <- makeTypeWithDepthMemo depth ofType
-    IType.NonNull -> do
+          pure $ case inner of
-      ofType <- note "No `ofType` found for nonnull" ty.ofType
+            Out.EnumBaseType enumType -> Out.NonNullEnumType enumType
-      inner <- makeTypeWithDepth depth ofType
+            Out.UnionBaseType unionType -> Out.NonNullUnionType unionType
-      pure $ case inner of
+            Out.ScalarBaseType scalarType -> Out.NonNullScalarType scalarType
-        Out.EnumBaseType enumType -> Out.NonNullEnumType enumType
+            Out.ObjectBaseType objectType -> Out.NonNullObjectType objectType
-        Out.UnionBaseType unionType -> Out.NonNullUnionType unionType
+            Out.ListBaseType listType -> Out.NonNullListType listType
-        Out.ScalarBaseType scalarType -> Out.NonNullScalarType scalarType
+            Out.InterfaceBaseType interfaceType -> Out.NonNullInterfaceType interfaceType
-        Out.ObjectBaseType objectType -> Out.NonNullObjectType objectType
+        IType.Object name fields -> do
-        Out.ListBaseType listType -> Out.NonNullListType listType
+          resolvers <- P.for fields $ \field -> do
-        Out.InterfaceBaseType interfaceType -> Out.NonNullInterfaceType interfaceType
+            resolver <-
-    IType.InputObject -> do
+              if depth >= 30
-      Left "input object in out position"
+                then
-    IType.Object -> do
+                  makeConstField
-      name <- note "No `name` found for object" ty.name
+                    (IType.field field.name IType.typeString)
-      fields <- note "No `fields` found for object" ty.fields
+                    (Type.String "Maximum depth exceeded")
-      resolvers <-
+                else makeChildField (depth + 1) field
-        if depth >= maxDepth
-          then pure []
-          else P.for fields $ \field -> do
-            resolver <- makeChildFieldWithDepth (depth + 1) field
             pure (field.name, resolver)
 
-      typenameResolver <-
+          typenameResolver <-
-        makeConstFieldWithDepth
+            makeConstField
-          depth
+              (IType.field "__typename" $ IType.nonNull IType.typeString)
-          (IType.field "__typename" $ IType.nonNull IType.typeString)
+              (Type.String name)
-          (Type.String name)
 
-      pure
+          pure
-        $ Out.NamedObjectType
+            $ Out.NamedObjectType
-        $ Type.ObjectType
+            $ Type.ObjectType
-          name
+              name
-          ty.description
+              -- ty.description
-          []
+              P.Nothing
-        $ HashMap.fromList
+              []
-        $ ("__typename", typenameResolver) : resolvers
+            $ HashMap.fromList
+            $ ("__typename", typenameResolver) : resolvers
+        _ -> do
+          Left $ "invalid type in out position: " <> show ty.kind
+
+    -- Creates a field which looks up it's value in the object returned by the
+    -- parent resolver.
+    makeChildField :: Int -> IType.Field -> Result (Out.Resolver IO)
+    makeChildField depth field = do
+      args <- P.for field.args $ \arg -> do
+        ty <- makeInType arg.type_
+        pure (arg.name, In.Argument arg.description ty arg.defaultValue)
+      ty <- makeTypeWithDepthMemo depth field.type_
+      let gqlField = Out.Field field.description ty $ HashMap.fromList args
+
+      pure $ Out.ValueResolver gqlField $ do
+        context <- ask
+
+        let defaultValue =
+              if Out.isNonNullType ty
+                then
+                  Type.String $
+                    "Error: field '"
+                      <> field.name
+                      <> "' not found "
+                else Type.Null
+
+        case context.values of
+          Type.Object obj ->
+            pure $
+              fromMaybe defaultValue $
+                HashMap.lookup field.name obj
+          _ -> pure defaultValue
+  in
+    makeTypeWithDepth 0
 
 
 makeConstField :: IType.Field -> Type.Value -> Result (Out.Resolver IO)
-makeConstField = makeConstFieldWithDepth 0
+makeConstField field value = do
-
+  ty <- makeType field.type_
-
-makeConstFieldWithDepth :: Int -> IType.Field -> Type.Value -> Result (Out.Resolver IO)
-makeConstFieldWithDepth depth field value = do
-  ty <- makeTypeWithDepth depth field.type_
   let gqlField = Out.Field field.description ty mempty
   pure $ Out.ValueResolver gqlField $ pure value
 
 
-makeChildField :: IType.Field -> Result (Out.Resolver IO)
+makeInType :: IType.IntrospectionType -> Result In.Type
-makeChildField = makeChildFieldWithDepth 0
+makeInType ty = do
-
-
-makeChildFieldWithDepth :: Int -> IType.Field -> Result (Out.Resolver IO)
-makeChildFieldWithDepth depth field = do
-  args <- P.for field.args $ \arg -> do
-    ty <- makeInTypeWithDepth depth arg.type_
-    pure (arg.name, In.Argument arg.description ty arg.defaultValue)
-  ty <- makeTypeWithDepth depth field.type_
-  let gqlField = Out.Field field.description ty $ HashMap.fromList args
-  pure $ Out.ValueResolver gqlField $ do
-    context <- ask
-    let defaultValue =
-          if Out.isNonNullType ty
-            then
-              Type.String $
-                "Error: field '"
-                  <> field.name
-                  <> "' not found "
-            else Type.Null
-    case context.values of
-      Type.Object obj ->
-        pure $
-          fromMaybe defaultValue $
-            HashMap.lookup field.name obj
-      _ -> pure defaultValue
-
-
-makeInTypeWithDepth :: Int -> IType.IntrospectionType -> Result In.Type
-makeInTypeWithDepth depth ty = do
   case ty.kind of
-    IType.Scalar -> do
+    IType.Scalar name -> do
-      name <- note "No `name` found for scalar" ty.name
       pure $ In.NamedScalarType $ Type.ScalarType name ty.description
-    IType.List -> do
+    IType.List ofType -> do
-      ofType <- note "No `ofType` found for list" ty.ofType
+      In.ListType <$> makeInType ofType
-      In.ListType <$> makeInTypeWithDepth depth ofType
+    IType.Enum name enumValues -> do
-    IType.Enum -> do
-      name <- note "No `name` found for enum" ty.name
-      enumValues <- note "No `enumValues` found for enum" ty.enumValues
       let variants = enumValues <&> \variant -> (variant.name, Type.EnumValue variant.description)
       pure $
         In.NamedEnumType $
           Type.EnumType name ty.description $
             HashMap.fromList variants
-    IType.NonNull -> do
+    IType.NonNull ofType -> do
-      ofType <- note "No `ofType` found for nonnull" ty.ofType
+      inner <- makeInType ofType
-      inner <- makeInTypeWithDepth depth ofType
       pure $ case inner of
         In.EnumBaseType enumType -> In.NonNullEnumType enumType
         In.ScalarBaseType scalarType -> In.NonNullScalarType scalarType
         In.InputObjectBaseType objectType -> In.NonNullInputObjectType objectType
         In.ListBaseType listType -> In.NonNullListType listType
-    IType.Object -> do
+    IType.InputObject name fields -> do
-      Left "out object in input position"
+      gqlFields <- P.for fields $ \field -> do
-    IType.InputObject -> do
+        inner <- makeInType field.type_
-      name <- note "No `name` found for object" ty.name
+        let inputField =
-      fields <- note "No `inputFields` found for object" ty.inputFields
+              In.InputField
-      gqlFields <-
+                field.description
-        if depth >= maxDepth
+                inner
-          then pure []
+                field.defaultValue
-          else P.for fields $ \field -> do
+        pure (field.name, inputField)
-            inner <- makeInTypeWithDepth (depth + 1) field.type_
-            let inputField =
-                  In.InputField
-                    field.description
-                    inner
-                    field.defaultValue
-            pure (field.name, inputField)
 
       pure
         $ In.NamedInputObjectType
@@ -180,3 +174,5 @@ makeInTypeWithDepth depth ty = do
           name
           ty.description
         $ HashMap.fromList gqlFields
+    _ -> do
+      Left $ "invalid type in input position: " <> show ty.kind

source/AirGQL/Introspection/Types.hs

@@ -1,5 +1,6 @@
 module AirGQL.Introspection.Types (
   Schema (..),
+  Name,
   IntrospectionType (..),
   TypeKind (..),
   Field (..),
@@ -11,7 +12,6 @@ module AirGQL.Introspection.Types (
   withArguments,
   inputValue,
   inputValueWithDescription,
-  withName,
   withDescription,
   fieldWithDescription,
   scalar,
@@ -46,6 +46,7 @@ import Protolude (
   execState,
   for_,
   not,
+  pure,
   show,
   when,
   ($),
@@ -126,47 +127,83 @@ typeDirectiveLocation =
     ]
 
 
-data TypeKind = Scalar | Object | Enum | InputObject | List | NonNull
+-- | The name of a graphql type.
+type Name = Text
+
+
+data TypeKind
+  = Scalar Name
+  | Object Name [Field]
+  | Enum Name [EnumValue]
+  | InputObject Name [InputValue]
+  | List IntrospectionType
+  | NonNull IntrospectionType
   deriving (Show, Generic)
 
 
--- $(deriveToGraphQL ''TypeKind)
-instance ToGraphQL TypeKind where
-  toGraphQL Scalar = Value.Enum "SCALAR"
-  toGraphQL Object = Value.Enum "OBJECT"
-  toGraphQL Enum = Value.Enum "ENUM"
-  toGraphQL InputObject = Value.Enum "INPUT_OBJECT"
-  toGraphQL List = Value.Enum "LIST"
-  toGraphQL NonNull = Value.Enum "NON_NULL"
-
-
 data IntrospectionType = IType
   { kind :: TypeKind
-  , name :: Maybe Text
   , description :: Maybe Text
-  , interfaces :: Maybe [IntrospectionType]
-  , possibleTypes :: Maybe [IntrospectionType]
-  , fields :: Maybe [Field]
-  , inputFields :: Maybe [InputValue]
-  , enumValues :: Maybe [EnumValue]
-  , ofType :: Maybe IntrospectionType
   }
   deriving (Show, Generic)
 
 
 instance ToGraphQL IntrospectionType where
-  toGraphQL ty =
+  toGraphQL ty = do
     Value.Object $
       HashMap.fromList
-        [ ("kind", toGraphQL ty.kind)
+        [
-        , ("name", toGraphQL ty.name)
+          ( "kind"
+          , case ty.kind of
+              Scalar _ -> Value.Enum "SCALAR"
+              Object _ _ -> Value.Enum "OBJECT"
+              Enum _ _ -> Value.Enum "ENUM"
+              InputObject _ _ -> Value.Enum "INPUT_OBJECT"
+              List _ -> Value.Enum "LIST"
+              NonNull _ -> Value.Enum "NON_NULL"
+          )
+        ,
+          ( "name"
+          , case ty.kind of
+              Scalar name -> Value.String name
+              Object name _ -> Value.String name
+              Enum name _ -> Value.String name
+              InputObject name _ -> Value.String name
+              _ -> Value.Null
+          )
         , ("description", toGraphQL ty.description)
-        , ("interfaces", toGraphQL ty.interfaces)
+        ,
-        , ("possibleTypes", toGraphQL ty.possibleTypes)
+          ( "interfaces"
-        , ("fields", toGraphQL ty.fields)
+          , case ty.kind of
-        , ("enumValues", toGraphQL ty.enumValues)
+              Object _ _ -> Value.List []
-        , ("inputFields", toGraphQL ty.inputFields)
+              _ -> Value.Null
-        , ("ofType", toGraphQL ty.ofType)
+          )
+        , ("possibleTypes", Value.Null)
+        ,
+          ( "fields"
+          , case ty.kind of
+              Object _ fields -> toGraphQL fields
+              _ -> Value.Null
+          )
+        ,
+          ( "enumValues"
+          , case ty.kind of
+              Enum _ variants -> toGraphQL variants
+              _ -> Value.Null
+          )
+        ,
+          ( "inputFields"
+          , case ty.kind of
+              InputObject _ fields -> toGraphQL fields
+              _ -> Value.Null
+          )
+        ,
+          ( "ofType"
+          , case ty.kind of
+              NonNull inner -> toGraphQL inner
+              List inner -> toGraphQL inner
+              _ -> Value.Null
+          )
         ]
 
 
@@ -199,67 +236,32 @@ typeIntrospectionType =
     ]
 
 
-emptyType :: TypeKind -> IntrospectionType
+mkType :: TypeKind -> IntrospectionType
-emptyType kind =
+mkType kind =
   IType
     { kind
-    , name = Nothing
     , description = Nothing
-    , interfaces = Nothing
-    , possibleTypes = Nothing
-    , fields = Nothing
-    , enumValues = Nothing
-    , inputFields = Nothing
-    , ofType = Nothing
     }
 
 
 nonNull :: IntrospectionType -> IntrospectionType
-nonNull ty =
+nonNull ty = mkType $ NonNull ty
-  (emptyType NonNull)
-    { ofType = Just ty
-    }
 
 
 list :: IntrospectionType -> IntrospectionType
-list ty =
+list ty = mkType $ List ty
-  (emptyType List)
-    { ofType = Just ty
-    }
 
 
 object :: Text -> [Field] -> IntrospectionType
-object name fields =
+object name fields = mkType $ Object name fields
-  (emptyType Object)
-    { fields = Just fields
-    , name = Just name
-    , interfaces = Just []
-    }
 
 
 inputObject :: Text -> [InputValue] -> IntrospectionType
-inputObject name fields =
+inputObject name fields = mkType $ InputObject name fields
-  (emptyType InputObject)
-    { inputFields = Just fields
-    , name = Just name
-    , interfaces = Just []
-    }
 
 
 enum :: Text -> [EnumValue] -> IntrospectionType
-enum name variants =
+enum name variants = mkType $ Enum name variants
-  (emptyType Enum)
-    { enumValues = Just variants
-    , name = Just name
-    }
-
-
-withName :: Text -> IntrospectionType -> IntrospectionType
-withName newName (IType{..}) =
-  IType
-    { name = Just newName
-    , ..
-    }
 
 
 withDescription :: Text -> IntrospectionType -> IntrospectionType
@@ -271,9 +273,7 @@ withDescription newDesc (IType{..}) =
 
 
 scalar :: Text -> IntrospectionType
-scalar tyName =
+scalar tyName = mkType $ Scalar tyName
-  emptyType Scalar
-    & withName tyName
 
 
 data Field = Field
@@ -463,19 +463,24 @@ collectSchemaTypes schema = do
 -- | Collect a map of all the named types occurring inside a type
 collectTypes :: IntrospectionType -> State (HashMap Text IntrospectionType) ()
 collectTypes ty = do
-  for_ ty.ofType collectTypes
+  -- Gives a name to the current type, and saves it.
-  for_ ty.name $ \name -> do
+  --
-    current <- get
+  -- If the type hadn't been found already, runs a custom continuation.
-    when (not $ HashMap.member name current) $ do
+  let insertType name continue = do
-      put $ HashMap.insert name ty current
+        current <- get
-      for_ ty.interfaces $ \interfaces -> do
+        when (not $ HashMap.member name current) $ do
-        for_ interfaces collectTypes
+          put $ HashMap.insert name ty current
-      for_ ty.possibleTypes $ \possibleTypes -> do
+          continue
-        for_ possibleTypes collectTypes
+
-      for_ ty.inputFields $ \inputFields -> do
+  case ty.kind of
-        for_ inputFields $ \thisField -> collectTypes thisField.type_
+    NonNull inner -> collectTypes inner
-      for_ ty.fields $ \fields -> do
+    List inner -> collectTypes inner
-        for_ fields $ \thisField -> do
+    Enum name _ -> insertType name $ pure ()
-          collectTypes thisField.type_
+    Scalar name -> insertType name $ pure ()
-          for_ thisField.args $ \arg ->
+    Object name fields -> insertType name $ do
-            collectTypes arg.type_
+      for_ fields $ \thisField -> do
+        collectTypes thisField.type_
+        for_ thisField.args $ \arg ->
+          collectTypes arg.type_
+    InputObject name fields -> insertType name $ do
+      for_ fields $ \thisField -> collectTypes thisField.type_