mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Parse queries returning schemas (#138)
This commit is contained in:
parent
efdcdad9ef
commit
234dc1477e
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user