mu-rpc 0.2.0.0 → 0.3.0.0

raw patch · 4 files changed

+405/−121 lines, 4 filesdep ~mu-schemaPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: mu-schema

API changes (from Hackage documentation)

Files

• mu-rpc.cabal +2/−2
• src/Mu/Rpc.hs +67/−41
• src/Mu/Rpc/Examples.hs +78/−44
• src/Mu/Server.hs +258/−34

@@ -1,5 +1,5 @@ name:               mu-rpc-version:            0.2.0.0+version:            0.3.0.0 synopsis:           Protocol-independent declaration of services and servers. description:   Protocol-independent declaration of services and servers for mu-haskell.@@ -30,7 +30,7 @@       base              >=4.12  && <5     , conduit     , mtl-    , mu-schema         >=0.2.0+    , mu-schema         >=0.3.0     , sop-core     , template-haskell     , text

@@ -14,10 +14,11 @@ and protocol. -} module Mu.Rpc (-  Service', Service(..)-, ServiceAnnotation, Package, FindPackageName-, Method(..), (:-->:)-, TypeRef(..), Argument(..), Return(..)+  Package', Package(..)+, Service', Service(..), Object+, ServiceAnnotation, Method', Method(..), ObjectField+, LookupService, LookupMethod+, TypeRef(..), Argument', Argument(..), Return(..) ) where  import           Data.Kind@@ -27,66 +28,91 @@ import           Mu.Schema import           Mu.Schema.Registry +-- | Packages whose names are given by type-level strings.+type Package' = Package Symbol Symbol Symbol -- | Services whose names are given by type-level strings.-type Service' = Service Symbol Symbol+type Service' = Service Symbol Symbol Symbol+-- | Methods whose names are given by type-level strings.+type Method' = Method Symbol Symbol Symbol+-- | Arguments whose names are given by type-level strings.+type Argument' = Argument Symbol Symbol -- | Annotations for services. At this moment, such --   annotations can be of any type. type ServiceAnnotation = Type +-- | A package is a set of services.+data Package serviceName methodName argName+  = Package (Maybe serviceName)+            [Service serviceName methodName argName]+ -- | A service is a set of methods.-data Service serviceName methodName-  = Service serviceName [ServiceAnnotation] [Method methodName]+data Service serviceName methodName argName+  = Service serviceName+            [ServiceAnnotation]+            [Method serviceName methodName argName] --- | An annotation to define a package name.---   This is used by some handlers, like gRPC.-data Package (s :: Symbol)+-- | A method is defined by its name, arguments, and return type.+data Method serviceName methodName argName+  = Method methodName [ServiceAnnotation]+           [Argument serviceName argName]+           (Return serviceName) --- | Find the 'Package' for a service, to be found---   as part of the annotations.-type family FindPackageName (anns :: [ServiceAnnotation]) :: Symbol where-  FindPackageName '[] = TypeError ('Text "Cannot find package name for the service")-  FindPackageName (Package s ': rest) = s-  FindPackageName (other     ': rest) = FindPackageName rest+-- Synonyms for GraphQL+-- | An object is a set of fields, in GraphQL lingo.+type Object = 'Service+-- | A field in an object takes some input objects,+--   and returns a value or some other object,+--   in GraphQL lingo.+type ObjectField = 'Method --- | A method is defined by its name, arguments, and return type.-data Method methodName-  = Method methodName [ServiceAnnotation] [Argument] Return+-- | Look up a service in a package definition using its name.+type family LookupService (ss :: [Service snm mnm anm]) (s :: snm) :: Service snm mnm anm where+  LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s)+  LookupService ('Service s anns ms ': ss) s = 'Service s anns ms+  LookupService (other              ': ss) s = LookupService ss s  -- | Look up a method in a service definition using its name.---   Useful to declare handlers like @HandlerIO (MyService :-->: "MyMethod")@.-type family (:-->:) (s :: Service snm mnm) (m :: mnm) :: Method mnm where-  'Service sname anns methods :-->: m = LookupMethod methods m--type family LookupMethod (s :: [Method mnm]) (m :: snm) :: Method snm where+type family LookupMethod (s :: [Method snm mnm anm]) (m :: mnm) :: Method snm mnm anm where   LookupMethod '[] m = TypeError ('Text "could not find method " ':<>: 'ShowType m)   LookupMethod ('Method m anns args r ': ms) m = 'Method m anns args r   LookupMethod (other                 ': ms) m = LookupMethod ms m --- | Defines how to handle the type-data TypeRef where-  ViaSchema   :: Schema typeName fieldName -> typeName -> TypeRef+-- | Defines a reference to a type, either primitive or coming from the schema.+--   'TypeRef's are used to define arguments and result types.+data TypeRef serviceName where+  -- | A primitive type.+  PrimitiveRef :: Type -> TypeRef serviceName+  -- | Chain with another service.+  ObjectRef    :: serviceName -> TypeRef serviceName+  -- | Point to schema.+  SchemaRef    :: Schema typeName fieldName -> typeName -> TypeRef serviceName   -- | Registry subject, type to convert to, and preferred serialization version-  ViaRegistry :: Registry -> Type -> Nat -> TypeRef+  RegistryRef  :: Registry -> Type -> Nat -> TypeRef serviceName   -- | To be used only during TH generation!-  ViaTH       :: TH.Type -> TypeRef+  THRef        :: TH.Type -> TypeRef serviceName+  -- Combinators found in the gRPC and GraphQL languages.+  -- | Represents a list of values.+  ListRef      :: TypeRef serviceName -> TypeRef serviceName+  -- | Represents a possibly-missing value.+  OptionalRef  :: TypeRef serviceName -> TypeRef serviceName  -- | Defines the way in which arguments are handled.-data Argument where+data Argument serviceName argName where   -- | Use a single value.-  ArgSingle :: TypeRef -> Argument+  ArgSingle :: Maybe argName -> [ServiceAnnotation]+            -> TypeRef serviceName -> Argument serviceName argName   -- | Consume a stream of values.-  ArgStream :: TypeRef -> Argument+  ArgStream :: Maybe argName -> [ServiceAnnotation]+            -> TypeRef serviceName -> Argument serviceName argName  -- | Defines the different possibilities for returning --   information from a method.-data Return where+data Return serviceName where   -- | Fire and forget.-  RetNothing :: Return+  RetNothing :: Return serviceName   -- | Return a single value.-  RetSingle :: TypeRef -> Return-  -- | Return a value or an error-  --   (this can be found in Avro IDL).-  RetThrows :: TypeRef -> TypeRef -> Return-  -- | Return a stream of values-  --   (this can be found in gRPC).-  RetStream :: TypeRef -> Return+  RetSingle  :: TypeRef serviceName -> Return serviceName+  -- | Return a stream of values.+  RetStream  :: TypeRef serviceName -> Return serviceName+  -- | Return a value or an error.+  RetThrows  :: TypeRef serviceName -> TypeRef serviceName -> Return serviceName

@@ -9,10 +9,9 @@ {-# language PartialTypeSignatures #-} {-# language PolyKinds             #-} {-# language ScopedTypeVariables   #-}-{-# language StandaloneDeriving    #-}+{-# language TypeApplications      #-} {-# language TypeFamilies          #-} {-# language TypeOperators         #-}-{-# language ViewPatterns          #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} {-| Description : Examples for service and server definitions@@ -23,7 +22,6 @@  import           Data.Conduit import           Data.Conduit.Combinators as C-import           Data.Functor.MaybeLike import qualified Data.Text                as T import           GHC.Generics @@ -36,54 +34,90 @@  type QuickstartSchema   = '[ 'DRecord "HelloRequest"-               '[ 'FieldDef "name" ('TPrimitive T.Text) ]+      '[ 'FieldDef "name" ('TPrimitive T.Text) ]      , 'DRecord "HelloResponse"-                '[ 'FieldDef "message" ('TPrimitive T.Text) ]+      '[ 'FieldDef "message" ('TPrimitive T.Text) ]      , 'DRecord "HiRequest"-               '[ 'FieldDef "number" ('TPrimitive Int) ]+      '[ 'FieldDef "number" ('TPrimitive Int) ]      ]  type QuickStartService-  = 'Service "Greeter" '[Package "helloworld"]-      '[ 'Method "SayHello" '[]-                 '[ 'ArgSingle ('ViaSchema QuickstartSchema "HelloRequest") ]-                 ('RetSingle ('ViaSchema QuickstartSchema "HelloResponse"))-       , 'Method "SayHi" '[]-                 '[ 'ArgSingle ('ViaSchema QuickstartSchema "HiRequest")]-                 ('RetStream ('ViaSchema QuickstartSchema "HelloResponse"))-       , 'Method "SayManyHellos" '[]-                 '[ 'ArgStream ('ViaSchema QuickstartSchema "HelloRequest")]-                 ('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) ]+  = 'Package ('Just "helloworld")+      '[ 'Service "Greeter" '[]+        '[ 'Method "SayHello" '[]+          '[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest") ]+            ('RetSingle ('SchemaRef QuickstartSchema "HelloResponse"))+        , 'Method "SayHi" '[]+          '[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HiRequest")]+            ('RetStream ('SchemaRef QuickstartSchema "HelloResponse"))+        , 'Method "SayManyHellos" '[]+          '[ 'ArgStream 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest")]+                ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ] -newtype HelloRequest f = HelloRequest { name :: f T.Text } deriving (Generic)-deriving instance Functor f => ToSchema f QuickstartSchema "HelloRequest" (HelloRequest f)-deriving instance Functor f => FromSchema f QuickstartSchema "HelloRequest" (HelloRequest f)+newtype HelloRequest = HelloRequest { name :: T.Text }+  deriving ( Show, Eq, Generic+           , ToSchema   QuickstartSchema "HelloRequest"+           , FromSchema QuickstartSchema "HelloRequest" ) -newtype HelloResponse f = HelloResponse { message :: f T.Text } deriving (Generic)-deriving instance Functor f => ToSchema f QuickstartSchema "HelloResponse" (HelloResponse f)-deriving instance Functor f => FromSchema f QuickstartSchema "HelloResponse" (HelloResponse f)+newtype HelloResponse = HelloResponse { message :: T.Text }+  deriving ( Show, Eq, Generic+           , ToSchema   QuickstartSchema "HelloResponse"+           , FromSchema QuickstartSchema "HelloResponse" ) -newtype HiRequest f = HiRequest { number :: f Int } deriving (Generic)-deriving instance Functor f => ToSchema f QuickstartSchema "HiRequest" (HiRequest f)-deriving instance Functor f => FromSchema f QuickstartSchema "HiRequest" (HiRequest f)+newtype HiRequest = HiRequest { number :: Int }+  deriving ( Show, Eq, Generic+           , ToSchema   QuickstartSchema "HiRequest"+           , FromSchema QuickstartSchema "HiRequest" ) -quickstartServer :: forall m f.-                    (MonadServer m, Applicative f, MaybeLike f)-                 => ServerT f QuickStartService m _+quickstartServer :: forall m. (MonadServer m)+                 => ServerT '[] QuickStartService m _ quickstartServer-  = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)-  where sayHello :: HelloRequest f -> m (HelloResponse f)-        sayHello (HelloRequest nm)-          = return (HelloResponse (("hi, " <>) <$> nm))-        sayHi :: HiRequest f-              -> ConduitT (HelloResponse f) Void m ()-              -> m ()-        sayHi (HiRequest (likeMaybe -> Just n)) sink-          = runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink-        sayHi (HiRequest _) sink-          = runConduit $ return () .| sink-        sayManyHellos :: ConduitT () (HelloRequest f) m ()-                      -> ConduitT (HelloResponse f) Void m ()-                      -> m ()-        sayManyHellos source sink-          = runConduit $ source .| C.mapM sayHello .| sink+  -- = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)+  = singleService ( method @"SayHello" sayHello+                  , method @"SayManyHellos" sayManyHellos+                  , method @"SayHi" sayHi )+  where+    sayHello :: HelloRequest -> m HelloResponse+    sayHello (HelloRequest nm)+      = pure $ HelloResponse $ "hi, " <> nm+    sayHi :: HiRequest+          -> ConduitT HelloResponse Void m ()+          -> m ()+    sayHi (HiRequest n) sink+      = runConduit $ C.replicate n (HelloResponse "hi!") .| sink+    sayManyHellos :: ConduitT () HelloRequest m ()+                  -> ConduitT HelloResponse Void m ()+                  -> m ()+    sayManyHellos source sink+      = runConduit $ source .| C.mapM sayHello .| sink++-- From https://www.apollographql.com/docs/apollo-server/schema/schema/+type ApolloService+  = 'Package ('Just "apollo")+      '[ Object "Book" '[]+        '[ ObjectField "title"  '[] '[] ('RetSingle ('PrimitiveRef String))+        , ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author"))+        ]+      , Object "Author" '[]+        '[ ObjectField "name"  '[] '[] ('RetSingle ('PrimitiveRef String))+        , ObjectField "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book")))+        ]+      ]++type ApolloBookAuthor = '[+    "Book"   ':-> (String, Integer)+  , "Author" ':-> Integer+  ]++apolloServer :: forall m. (MonadServer m) => ServerT ApolloBookAuthor ApolloService m _+apolloServer+  = resolver+      ( object @"Author" ( field @"name"   authorName+                         , field @"books"  authorBooks )+      , object @"Book"   ( field @"author" (pure . snd)+                         , field @"title"  (pure . fst) ) )+  where+    authorName :: Integer -> m String+    authorName _ = pure "alex"  -- this would run in the DB+    authorBooks :: Integer -> m [(String, Integer)]+    authorBooks _ = pure []

@@ -3,13 +3,17 @@ {-# language ExistentialQuantification #-} {-# language FlexibleContexts          #-} {-# language FlexibleInstances         #-}+{-# language FunctionalDependencies    #-} {-# language GADTs                     #-}-{-# language MultiParamTypeClasses     #-}+{-# language PatternSynonyms           #-} {-# language PolyKinds                 #-} {-# language RankNTypes                #-}+{-# language ScopedTypeVariables       #-}+{-# language TypeApplications          #-} {-# language TypeFamilies              #-} {-# language TypeOperators             #-} {-# language UndecidableInstances      #-}+{-# language ViewPatterns              #-} {-| Description : Protocol-independent declaration of servers. @@ -17,16 +21,26 @@ of handlers (represented by 'HandlersT'), one for each operation in the corresponding Mu service declaration. -In general, you should declare a server as:+In general, you can declare a server by naming+each of the methods with their handlers: -> server :: MonadServer m => ServerT w MyService m _+> server :: MonadServer m => ServerT MyService m _+> server = singleService ( method @"m1" h1+>                        , method @"m2" h2+>                        , ... )++or by position:++> server :: MonadServer m => ServerT MyService m _ > server = Server (h1 :<|>: h2 :<|>: ... :<|>: H0)  where each of @h1@, @h2@, ... handles each method in @MyService@ /in the order they were declared/.-The @_@ in the type allows GHC to fill in the boring-and long type you would need to write there otherwise. +In both cases, the @_@ in the type allows GHC to fill+in the boring and long type you would need to write+there otherwise.+ /Implementation note/: exceptions raised in handlers produce an error to be sent as response to the client. We recommend you to catch exceptions and return custom@@ -34,18 +48,26 @@ -} module Mu.Server (   -- * Servers and handlers-  MonadServer, ServerT(..), HandlersT(..)+  MonadServer, ServiceChain, noContext+  -- ** Definitions by name+, singleService, method, resolver, object, field, NamedList(..)+  -- ** Definitions by position+, SingleServerT, pattern Server+, ServerT(..), ServicesT(..), HandlersT(.., (:<|>:))   -- ** Simple servers using only IO , ServerErrorIO, ServerIO   -- * Errors which might be raised , serverError, ServerError(..), ServerErrorCode(..)   -- ** Useful when you do not want to deal with errors , alwaysOk+  -- * For internal use+, Handles, FromRef, ToRef ) where  import           Control.Monad.Except import           Data.Conduit import           Data.Kind+import           GHC.TypeLits  import           Mu.Rpc import           Mu.Schema@@ -54,9 +76,11 @@ type MonadServer m = (MonadError ServerError m, MonadIO m) -- | Simplest monad which satisfies 'MonadServer'. type ServerErrorIO = ExceptT ServerError IO--- | Simple 'ServerT' which uses only 'IO' and errors.-type ServerIO w srv = ServerT w srv ServerErrorIO +-- | Simple 'ServerT' which uses only 'IO' and errors,+--   and whose service has no back-references.+type ServerIO srv = ServerT '[] srv ServerErrorIO+ -- | Stop the current handler, --   returning an error to the client. serverError :: (MonadError ServerError m)@@ -70,6 +94,11 @@          => IO a -> m a alwaysOk = liftIO +-- | To declare that the function doesn't use+--   its context.+noContext :: b -> a -> b+noContext = const+ -- | Errors raised in a handler. data ServerError   = ServerError ServerErrorCode String@@ -87,11 +116,38 @@   | NotFound   deriving (Eq, Show) +-- | Defines a mapping between outcome of+--   a service, and its representation as+--   Haskell type.+type ServiceChain snm = Mappings snm Type++-- | A server for a single service,+--   like most RPC ones.+type SingleServerT = ServerT '[]++-- | Definition of a complete server+--   for a set of services, with possible+--   references between them.+data ServerT (chn :: ServiceChain snm) (s :: Package snm mnm anm)+             (m :: Type -> Type) (hs :: [[Type]]) where+  Services :: ServicesT chn s m hs+           -> ServerT chn ('Package pname s) m hs++pattern Server :: (MappingRight chn sname ~ ())+               => HandlersT chn () methods m hs+               -> ServerT chn ('Package pname '[ 'Service sname sanns methods ]) m '[hs]+pattern Server svr = Services (svr :<&>: S0)++infixr 3 :<&>: -- | Definition of a complete server for a service.-data ServerT (w :: Type -> Type) (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where-  Server :: HandlersT w methods m hs -> ServerT w ('Service sname anns methods) m hs+data ServicesT (chn :: ServiceChain snm) (s :: [Service snm mnm anm])+               (m :: Type -> Type) (hs :: [[Type]]) where+  S0 :: ServicesT chn '[] m '[]+  (:<&>:) :: HandlersT chn (MappingRight chn sname) methods m hs+          -> ServicesT chn rest m hss+          -> ServicesT chn ('Service sname anns methods ': rest) m (hs ': hss) -infixr 5 :<|>:+infixr 4 :<||>: -- | 'HandlersT' is a sequence of handlers. --   Note that the handlers for your service --   must appear __in the same order__ as they@@ -111,36 +167,204 @@ --   * Output streams turn into an __additional argument__ --     of type @Conduit t Void m ()@. This stream should --     be connected to a source to get the elements.-data HandlersT (w :: Type -> Type) (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where-  H0 :: HandlersT w '[] m '[]-  (:<|>:) :: Handles w args ret m h => h -> HandlersT w ms m hs-          -> HandlersT w ('Method name anns args ret ': ms) m (h ': hs)+data HandlersT (chn :: ServiceChain snm)+               (inh :: *) (methods :: [Method snm mnm anm])+               (m :: Type -> Type) (hs :: [Type]) where+  H0 :: HandlersT chn inh '[] m '[]+  (:<||>:) :: Handles chn args ret m h+           => (inh -> h) -> HandlersT chn inh ms m hs+           -> HandlersT chn inh ('Method name anns args ret ': ms) m (h ': hs) --- Define a relation for handling-class Handles (w :: Type -> Type) (args :: [Argument]) (ret :: Return)+infixr 4 :<|>:+pattern (:<|>:) :: (Handles chn args ret m h)+                => h -> HandlersT chn () ms m hs+                -> HandlersT chn () ('Method name anns args ret ': ms) m (h ': hs)+pattern x :<|>: xs <- (($ ()) -> x) :<||>: xs where+  x :<|>: xs = noContext x :<||>: xs++-- | Defines a relation for handling.+class Handles (chn :: ServiceChain snm)+              (args :: [Argument snm anm]) (ret :: Return snm)               (m :: Type -> Type) (h :: Type)-class ToRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type)-class FromRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type)+-- | Defines whether a given type @t@+--   can be turned into the 'TypeRef' @ref@.+class ToRef   (chn :: ServiceChain snm)+              (ref :: TypeRef snm) (t :: Type)+-- | Defines whether a given type @t@+--   can be obtained from the 'TypeRef' @ref@.+class FromRef (chn :: ServiceChain snm)+              (ref :: TypeRef snm) (t :: Type)  -- Type references-instance ToSchema w sch sty t => ToRef w ('ViaSchema sch sty) t-instance ToRef w ('ViaRegistry subject t last) t-instance FromSchema w sch sty t => FromRef w ('ViaSchema sch sty) t-instance FromRef w ('ViaRegistry subject t last) t+instance t ~ s => ToRef chn ('PrimitiveRef t) s+instance ToSchema sch sty t => ToRef chn ('SchemaRef sch sty) t+instance MappingRight chn ref ~ t => ToRef chn ('ObjectRef ref) t+instance t ~ s => ToRef chn ('RegistryRef subject t last) s+instance (ToRef chn ref t, [t] ~ s) => ToRef chn ('ListRef ref) s+instance (ToRef chn ref t, Maybe t ~ s) => ToRef chn ('OptionalRef ref) s +instance t ~ s => FromRef chn ('PrimitiveRef t) s+instance FromSchema sch sty t => FromRef chn ('SchemaRef sch sty) t+instance MappingRight chn ref ~ t => FromRef chn ('ObjectRef ref) t+instance t ~ s => FromRef chn ('RegistryRef subject t last) s+instance (FromRef chn ref t, [t] ~ s) => FromRef chn ('ListRef ref) s+instance (FromRef chn ref t, Maybe t ~ s) => FromRef chn ('OptionalRef ref) s+ -- Arguments-instance (FromRef w ref t, Handles w args ret m h,+instance (FromRef chn ref t, Handles chn args ret m h,           handler ~ (t -> h))-         => Handles w ('ArgSingle ref ': args) ret m handler-instance (MonadError ServerError m, FromRef w ref t, Handles w args ret m h,+         => Handles chn ('ArgSingle aname anns ref ': args) ret m handler+instance (MonadError ServerError m, FromRef chn ref t, Handles chn args ret m h,           handler ~ (ConduitT () t m () -> h))-         => Handles w ('ArgStream ref ': args) ret m handler+         => Handles chn ('ArgStream aname anns ref ': args) ret m handler -- Result with exception instance (MonadError ServerError m, handler ~ m ())-         => Handles w '[] 'RetNothing m handler-instance (MonadError ServerError m, ToRef w eref e, ToRef w vref v, handler ~ m (Either e v))-         => Handles w '[] ('RetThrows eref vref) m handler-instance (MonadError ServerError m, ToRef w ref v, handler ~ m v)-         => Handles w '[] ('RetSingle ref) m handler-instance (MonadError ServerError m, ToRef w ref v, handler ~ (ConduitT v Void m () -> m ()))-         => Handles w '[] ('RetStream ref) m handler+         => Handles chn '[] 'RetNothing m handler+instance (MonadError ServerError m, ToRef chn eref e, ToRef chn vref v, handler ~ m (Either e v))+         => Handles chn '[] ('RetThrows eref vref) m handler+instance (MonadError ServerError m, ToRef chn ref v, handler ~ m v)+         => Handles chn '[] ('RetSingle ref) m handler+instance (MonadError ServerError m, ToRef chn ref v, handler ~ (ConduitT v Void m () -> m ()))+         => Handles chn '[] ('RetStream ref) m handler++-- SIMPLER WAY TO DECLARE SERVICES++-- | Declares the handler for a method in the service.+--   Intended to be used with @TypeApplications@:+--+--   > method @"myMethod" myHandler+method :: forall n p. p -> Named n (() -> p)+method f = Named (\() -> f)++-- | Declares the handler for a field in an object.+--   Intended to be used with @TypeApplications@:+--+--   > field @"myField" myHandler+field :: forall n h. h -> Named n h+field  = Named++-- | Defines a server for a package with a single service.+--   Intended to be used with a tuple of 'method's:+--+--   > singleService (method @"m1" h1, method @"m2" h2)+singleService+  :: (ToNamedList p nl, ToHandlers chn () methods m hs nl, MappingRight chn sname ~ ())+  => p -> ServerT chn ('Package pname '[ 'Service sname sanns methods ]) m '[hs]+singleService nl = Server $ toHandlers $ toNamedList nl++-- | Defines the implementation of a single GraphQL object,+--   which translates as a single Mu service.+--   Intended to be used with @TypeApplications@+--   and a tuple of 'field's:+--+--   > object @"myObject" (field @"f1" h1, fielf @"f2" h2)+--+--   Note: for the root objects in GraphQL (query, mutation, subscription)+--   use 'method' instead of 'object'.+object+  :: forall sname p nl chn ms m hs.+     (ToNamedList p nl, ToHandlers chn (MappingRight chn sname) ms m hs nl)+  => p -> Named sname (HandlersT chn (MappingRight chn sname) ms m hs)+object nl = Named $ toHandlers $ toNamedList nl++-- | Combines the implementation of several GraphQL objects,+--   which means a whole Mu service for a GraphQL server.+--   Intented to be used with a tuple of 'objects':+--+--   > resolver (object @"o1" ..., object @"o2" ...)+resolver+  :: (ToNamedList p nl, ToServices chn ss m hs nl)+  => p -> ServerT chn ('Package pname ss) m hs+resolver nl = Services $ toServices $ toNamedList nl++-- | A value tagged with a type-level name.+data Named n h where+  Named :: forall n h. h -> Named n h++infixr 4 :|:+-- | Heterogeneous list in which each element+--   is tagged with a type-level name.+data NamedList (hs :: [(Symbol, *)]) where+  N0    :: NamedList '[]+  (:|:) :: Named n h -> NamedList hs+        -> NamedList ('(n, h) ': hs)++-- | Used to turn tuples into 'NamedList's.+class ToNamedList p nl | p -> nl where+  toNamedList :: p -> NamedList nl++instance ToNamedList (NamedList nl) nl where+  toNamedList = id+instance ToNamedList () '[] where+  toNamedList _ = N0+instance ToNamedList (Named n h) '[ '(n, h) ] where+  toNamedList n = n :|: N0+instance ToNamedList (Named n1 h1, Named n2 h2)+                     '[ '(n1, h1), '(n2, h2) ] where+  toNamedList (n1, n2) = n1 :|: n2 :|: N0+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3)+                     '[ '(n1, h1), '(n2, h2), '(n3, h3) ] where+  toNamedList (n1, n2, n3) = n1 :|: n2 :|: n3 :|: N0+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4)+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4) ] where+  toNamedList (n1, n2, n3, n4) = n1 :|: n2 :|: n3 :|: n4 :|: N0+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5)+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5) ] where+  toNamedList (n1, n2, n3, n4, n5) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: N0+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6)+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6) ] where+  toNamedList (n1, n2, n3, n4, n5, n6) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: N0+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7)+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7) ] where+  toNamedList (n1, n2, n3, n4, n5, n6, n7) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: N0+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7, Named n8 h8)+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8) ] where+  toNamedList (n1, n2, n3, n4, n5, n6, n7, n8) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: n8 :|: N0+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7, Named n8 h8, Named n9 h9)+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9) ] where+  toNamedList (n1, n2, n3, n4, n5, n6, n7, n8, n9) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: n8 :|: n9 :|: N0++class ToHandlers chn inh ms m hs nl | chn inh ms m nl -> hs where+  toHandlers :: NamedList nl+             -> HandlersT chn inh ms m hs++instance ToHandlers chn inh '[] m '[] nl where+  toHandlers _ = H0+instance (FindHandler name inh h nl, Handles chn args ret m h, ToHandlers chn inh ms m hs nl)+         => ToHandlers chn inh ('Method name anns args ret ': ms) m (h ': hs) nl where+  toHandlers nl = findHandler (Proxy @name) nl :<||>: toHandlers nl++class FindHandler name inh h nl | name nl -> inh h where+  findHandler :: Proxy name -> NamedList nl -> inh -> h+instance (inh ~ h, h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name))+         => FindHandler name inh h '[] where+  findHandler = error "this should never be called"+instance {-# OVERLAPS #-} (inh ~ inh', h ~ h')+         => FindHandler name inh h ( '(name, inh' -> h') ': rest ) where+  findHandler _ (Named f :|: _) = f+instance {-# OVERLAPPABLE #-} FindHandler name inh h rest+         => FindHandler name inh h (thing ': rest) where+  findHandler p (_ :|: rest) = findHandler p rest++class ToServices chn ss m hs nl | chn ss m nl -> hs where+  toServices :: NamedList nl+             -> ServicesT chn ss m hs++instance ToServices chn '[] m '[] nl where+  toServices _ = S0+instance ( FindService name (HandlersT chn (MappingRight chn name) methods m h) nl+         , ToServices chn ss m hs nl)+         => ToServices chn ('Service name anns methods ': ss) m (h ': hs) nl where+  toServices nl = findService (Proxy @name) nl :<&>: toServices nl++class FindService name h nl | name nl -> h where+  findService :: Proxy name -> NamedList nl -> h+instance (h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name))+         => FindService name h '[] where+  findService = error "this should never be called"+instance {-# OVERLAPS #-} (h ~ h')+         => FindService name h ( '(name, h') ': rest ) where+  findService _ (Named f :|: _) = f+instance {-# OVERLAPPABLE #-} FindService name h rest+         => FindService name h (thing ': rest) where+  findService p (_ :|: rest) = findService p rest