Parse queries returning schemas (#138)

graphql/src/Mu/GraphQL/Query/Definition.hs

@@ -48,8 +48,34 @@ data ArgumentValue' (p :: Package snm mnm anm) (r :: TypeRef snm) where
 
 data ReturnQuery (p :: Package snm mnm anm) (r :: TypeRef snm) where
   RetPrimitive :: ReturnQuery p ('PrimitiveRef t)
-  RetSchema    :: ReturnQuery p ('SchemaRef sch sty)
+  RetSchema    :: SchemaQuery sch (sch :/: sty)
+               -> ReturnQuery p ('SchemaRef sch sty)
   RetList      :: ReturnQuery p r -> ReturnQuery p ('ListRef r)
   RetOptional  :: ReturnQuery p r -> ReturnQuery p ('OptionalRef r)
   RetObject    :: ServiceQuery ('Package pname ss) (LookupService ss s)
                -> ReturnQuery ('Package pname ss) ('ObjectRef s)
+
+data SchemaQuery (sch :: Schema tn fn) (t :: TypeDef tn fn) where
+  QueryEnum   :: SchemaQuery sch ('DEnum nm choices)
+  QueryRecord :: [OneFieldQuery sch fs]
+              -> SchemaQuery sch ('DRecord ty fs)
+
+data OneFieldQuery (sch :: Schema tn fn) (fs :: [FieldDef tn fn]) where
+  OneFieldQuery
+    :: Maybe Text
+    -> NS (ChosenFieldQuery sch) fs
+    -> OneFieldQuery sch fs
+
+data ChosenFieldQuery (sch :: Schema tn fn) (f :: FieldDef tn fn) where
+  ChosenFieldQuery
+    :: ReturnSchemaQuery sch r
+    -> ChosenFieldQuery sch ('FieldDef name r)
+
+data ReturnSchemaQuery (sch :: Schema tn fn) (r :: FieldType tn) where
+  RetSchPrimitive :: ReturnSchemaQuery sch ('TPrimitive t)
+  RetSchSchema    :: SchemaQuery sch (sch :/: sty)
+                  -> ReturnSchemaQuery sch ('TSchematic sty)
+  RetSchList      :: ReturnSchemaQuery sch r
+                  -> ReturnSchemaQuery sch ('TList r)
+  RetSchOptional  :: ReturnSchemaQuery sch r
+                  -> ReturnSchemaQuery sch ('TOption r)

graphql/src/Mu/GraphQL/Query/Parse.hs

@@ -419,8 +419,10 @@ instance ParseReturn p ('PrimitiveRef t) where
     = pure RetPrimitive
   parseReturn _ _ fname _
     = throwError $ "field '" <> fname <> "' should not have a selection of subfields"
-instance ParseReturn p ('SchemaRef sch sty) where
-  parseReturn _ _ _ _ = pure RetSchema
+instance (ParseSchema sch (sch :/: sty))
+         => ParseReturn p ('SchemaRef sch sty) where
+  parseReturn vmap frmap fname s
+    = RetSchema <$> parseSchema vmap frmap fname s
 instance ParseReturn p r
          => ParseReturn p ('ListRef r) where
   parseReturn vmap frmap fname s
@@ -435,3 +437,106 @@ instance ( p ~ 'Package pname ss,
          ) => ParseReturn p ('ObjectRef s) where
   parseReturn vmap frmap _ s
     = RetObject <$> parseQuery (Proxy @p) (Proxy @s) vmap frmap s
+
+class ParseSchema (s :: Schema') (t :: TypeDef Symbol Symbol) where
+  parseSchema :: MonadError T.Text f
+              => VariableMap
+              -> FragmentMap
+              -> T.Text
+              -> GQL.SelectionSet
+              -> f (SchemaQuery s t)
+instance ParseSchema sch ('DEnum name choices) where
+  parseSchema _ _ _ []
+    = pure QueryEnum
+  parseSchema _ _ fname _
+    = throwError $ "field '" <> fname <> "' should not have a selection of subfields"
+instance (KnownSymbol name, ParseField sch fields)
+         => ParseSchema sch ('DRecord name fields) where
+  parseSchema vmap frmap _ s
+    = QueryRecord <$> parseSchemaQuery (Proxy @sch) (Proxy @('DRecord name fields)) vmap frmap s
+
+parseSchemaQuery ::
+  forall (sch :: Schema') t (rname :: Symbol) fields f.
+  ( MonadError T.Text f
+  , t ~  'DRecord rname fields
+  , KnownSymbol rname
+  , ParseField sch fields ) =>
+  Proxy sch ->
+  Proxy t ->
+  VariableMap -> FragmentMap -> GQL.SelectionSet ->
+  f [OneFieldQuery sch fields]
+parseSchemaQuery _ _ _ _ [] = pure []
+parseSchemaQuery pp ps vmap frmap (GQL.SelectionField fld : ss)
+  = (++) <$> (maybeToList <$> fieldToMethod fld)
+         <*> parseSchemaQuery pp ps vmap frmap ss
+  where
+    fieldToMethod :: GQL.Field -> f (Maybe (OneFieldQuery sch fields))
+    fieldToMethod (GQL.Field alias name args dirs sels)
+      | any (shouldSkip vmap) dirs
+      = pure Nothing
+      | _:_ <- args
+      = throwError "this field does not support arguments"
+      | otherwise
+      = Just . OneFieldQuery (GQL.unName . GQL.unAlias <$> alias)
+         <$> selectField (T.pack $ nameVal (Proxy @rname)) vmap frmap name sels
+parseSchemaQuery pp ps vmap frmap (GQL.SelectionFragmentSpread (GQL.FragmentSpread nm dirs) : ss)
+  | Just fr <- HM.lookup (GQL.unName nm) frmap
+  = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ GQL._fdDirectives fr)
+       then (++) <$> parseSchemaQuery pp ps vmap frmap (GQL._fdSelectionSet fr)
+                 <*> parseSchemaQuery pp ps vmap frmap ss
+       else parseSchemaQuery pp ps vmap frmap ss
+  | otherwise  -- the fragment definition was not found
+  = throwError $ "fragment '" <> GQL.unName nm <> "' was not found"
+parseSchemaQuery _ _ _ _ (_ : _)  -- Inline fragments are not yet supported
+  = throwError "inline fragments are not (yet) supported"
+
+class ParseField (sch :: Schema') (fs :: [FieldDef Symbol Symbol]) where
+  selectField ::
+    MonadError T.Text f =>
+    T.Text ->
+    VariableMap ->
+    FragmentMap ->
+    GQL.Name ->
+    GQL.SelectionSet ->
+    f (NS (ChosenFieldQuery sch) fs)
+
+instance ParseField sch '[] where
+  selectField tyName _ _ (GQL.unName -> wanted) _
+    = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'"
+instance
+  (KnownSymbol fname, ParseField sch fs, ParseSchemaReturn sch r) =>
+  ParseField sch ('FieldDef fname r ': fs)
+  where
+  selectField tyName vmap frmap w@(GQL.unName -> wanted) sels
+    | wanted == mname
+    = Z <$> (ChosenFieldQuery <$> parseSchemaReturn vmap frmap wanted sels)
+    | otherwise
+    = S <$> selectField tyName vmap frmap w sels
+    where
+      mname = T.pack $ nameVal (Proxy @fname)
+
+class ParseSchemaReturn (sch :: Schema') (r :: FieldType Symbol) where
+  parseSchemaReturn :: MonadError T.Text f
+                    => VariableMap
+                    -> FragmentMap
+                    -> T.Text
+                    -> GQL.SelectionSet
+                    -> f (ReturnSchemaQuery sch r)
+
+instance ParseSchemaReturn sch ('TPrimitive t) where
+  parseSchemaReturn _ _ _ []
+    = pure RetSchPrimitive
+  parseSchemaReturn _ _ fname _
+    = throwError $ "field '" <> fname <> "' should not have a selection of subfields"
+instance ( ParseSchema sch (sch :/: sty) )
+         => ParseSchemaReturn sch ('TSchematic sty) where
+  parseSchemaReturn vmap frmap fname s
+    = RetSchSchema <$> parseSchema vmap frmap fname s
+instance ParseSchemaReturn sch r
+         => ParseSchemaReturn sch ('TList r) where
+  parseSchemaReturn vmap frmap fname s
+    = RetSchList <$> parseSchemaReturn vmap frmap fname s
+instance ParseSchemaReturn sch r
+         => ParseSchemaReturn sch ('TOption r) where
+  parseSchemaReturn vmap frmap fname s
+    = RetSchOptional <$> parseSchemaReturn vmap frmap fname s

graphql/src/Mu/GraphQL/Query/Run.hs

@@ -206,9 +206,10 @@ class ToRef chn r l => ResultConversion p whole chn r l where
 instance Aeson.ToJSON t => ResultConversion p whole chn ('PrimitiveRef t) t where
   convertResult _ RetPrimitive = pure . Just . Aeson.toJSON
 instance ( ToSchema sch l r
-         , Aeson.ToJSON (Term sch (sch :/: l)) )
+         , RunSchemaQuery sch (sch :/: l) )
          => ResultConversion p whole chn ('SchemaRef sch l) r where
-  convertResult _ RetSchema = pure . Just . Aeson.toJSON . toSchema' @_ @_ @sch @r
+  convertResult _ (RetSchema r) t
+    = pure $ Just $ runSchemaQuery (toSchema' @_ @_ @sch @r t) r
 instance ( MappingRight chn ref ~ t
          , MappingRight chn sname ~ t
          , LookupService ss ref ~ 'Service sname sanns ms
@@ -226,3 +227,58 @@ instance ResultConversion p whole chn r s
         => ResultConversion p whole chn ('ListRef r) [s] where
   convertResult whole (RetList q) xs
     = Just . Aeson.toJSON . catMaybes <$> mapM (convertResult whole q) xs
+
+class RunSchemaQuery sch r where
+  runSchemaQuery
+    :: Term sch r
+    -> SchemaQuery sch r
+    -> Aeson.Value
+instance ( Aeson.ToJSON (Term sch ('DEnum name choices)) )
+         => RunSchemaQuery sch ('DEnum name choices) where
+  runSchemaQuery t _ = Aeson.toJSON t
+instance ( RunSchemaField sch fields )
+         => RunSchemaQuery sch ('DRecord rname fields) where
+  runSchemaQuery (TRecord args) (QueryRecord rs)
+    = Aeson.object $ mapMaybe runOneQuery rs
+    where
+      runOneQuery (OneFieldQuery nm choice)
+        = let (val, fname) = runSchemaField args choice
+              realName = fromMaybe fname nm
+          in (realName,) <$> val
+
+class RunSchemaField sch args where
+  runSchemaField
+    :: NP (Field sch) args
+    -> NS (ChosenFieldQuery sch) args
+    -> (Maybe Aeson.Value, T.Text)
+
+instance RunSchemaField sch '[] where
+  runSchemaField = error "this should never be called"
+instance (KnownName fname, RunSchemaType sch t, RunSchemaField sch fs)
+         => RunSchemaField sch ('FieldDef fname t ': fs) where
+  runSchemaField (Field x :* _) (Z (ChosenFieldQuery c))
+    = (runSchemaType x c, T.pack $ nameVal (Proxy @fname))
+  runSchemaField (_ :* xs) (S rest)
+    = runSchemaField xs rest
+
+class RunSchemaType sch t where
+  runSchemaType
+    :: FieldValue sch t
+    -> ReturnSchemaQuery sch t
+    -> Maybe Aeson.Value
+instance ( Aeson.ToJSON t )
+         => RunSchemaType sch ('TPrimitive t) where
+  runSchemaType (FPrimitive x) _
+    = Just $ Aeson.toJSON x
+instance RunSchemaType sch r
+         => RunSchemaType sch ('TList r) where
+  runSchemaType (FList xs) (RetSchList r)
+    = Just . Aeson.toJSON $ mapMaybe (`runSchemaType` r) xs
+instance RunSchemaType sch r
+         => RunSchemaType sch ('TOption r) where
+  runSchemaType (FOption xs) (RetSchOptional r)
+    = xs >>= flip runSchemaType r
+instance RunSchemaQuery sch (sch :/: l)
+         => RunSchemaType sch ('TSchematic l) where
+  runSchemaType (FSchematic t) (RetSchSchema r)
+    = Just $ runSchemaQuery t r