{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language ExistentialQuantification #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language FunctionalDependencies #-}
{-# language GADTs #-}
{-# language PatternSynonyms #-}
{-# language PolyKinds #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
{-# language ViewPatterns #-}
module Mu.Server (
MonadServer, ServiceChain, noContext
, singleService, method, resolver, object, field, NamedList(..)
, SingleServerT, pattern Server
, ServerT(..), ServicesT(..), HandlersT(.., (:<|>:))
, ServerErrorIO, ServerIO
, serverError, ServerError(..), ServerErrorCode(..)
, alwaysOk
, Handles, FromRef, ToRef
) where
import Control.Monad.Except
import Data.Conduit
import Data.Kind
import GHC.TypeLits
import Mu.Rpc
import Mu.Schema
type MonadServer m = (MonadError ServerError m, MonadIO m)
type ServerErrorIO = ExceptT ServerError IO
type ServerIO srv = ServerT '[] srv ServerErrorIO
serverError :: (MonadError ServerError m)
=> ServerError -> m a
serverError :: ServerError -> m a
serverError = ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
alwaysOk :: (MonadIO m)
=> IO a -> m a
alwaysOk :: IO a -> m a
alwaysOk = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
noContext :: b -> a -> b
noContext :: b -> a -> b
noContext = b -> a -> b
forall a b. a -> b -> a
const
data ServerError
= ServerError ServerErrorCode String
data ServerErrorCode
= Unknown
| Unavailable
| Unimplemented
| Unauthenticated
| Internal
| Invalid
| NotFound
deriving (ServerErrorCode -> ServerErrorCode -> Bool
(ServerErrorCode -> ServerErrorCode -> Bool)
-> (ServerErrorCode -> ServerErrorCode -> Bool)
-> Eq ServerErrorCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ServerErrorCode -> ServerErrorCode -> Bool
$c/= :: ServerErrorCode -> ServerErrorCode -> Bool
== :: ServerErrorCode -> ServerErrorCode -> Bool
$c== :: ServerErrorCode -> ServerErrorCode -> Bool
Eq, Int -> ServerErrorCode -> ShowS
[ServerErrorCode] -> ShowS
ServerErrorCode -> String
(Int -> ServerErrorCode -> ShowS)
-> (ServerErrorCode -> String)
-> ([ServerErrorCode] -> ShowS)
-> Show ServerErrorCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerErrorCode] -> ShowS
$cshowList :: [ServerErrorCode] -> ShowS
show :: ServerErrorCode -> String
$cshow :: ServerErrorCode -> String
showsPrec :: Int -> ServerErrorCode -> ShowS
$cshowsPrec :: Int -> ServerErrorCode -> ShowS
Show)
type ServiceChain snm = Mappings snm Type
type SingleServerT = ServerT '[]
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 $bServer :: HandlersT chn () methods m hs
-> ServerT
chn ('Package pname '[ 'Service sname sanns methods]) m '[hs]
$mServer :: forall r serviceName mnm anm (chn :: Mappings serviceName *)
(sname :: serviceName) (methods :: [Method serviceName mnm anm])
(m :: * -> *) (hs :: [*]) (pname :: Maybe serviceName)
(sanns :: [*]).
(MappingRight chn sname ~ ()) =>
ServerT
chn ('Package pname '[ 'Service sname sanns methods]) m '[hs]
-> (HandlersT chn () methods m hs -> r) -> (Void# -> r) -> r
Server svr = Services (svr :<&>: S0)
infixr 3 :<&>:
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 4 :<||>:
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)
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 $b:<|>: :: h
-> HandlersT chn () ms m hs
-> HandlersT chn () ('Method name anns args ret : ms) m (h : hs)
$m:<|>: :: forall r serviceName anm mnm (chn :: ServiceChain serviceName)
(args :: [Argument serviceName anm]) (ret :: Return serviceName)
(m :: * -> *) h (ms :: [Method serviceName mnm anm]) (hs :: [*])
(name :: mnm) (anns :: [*]).
Handles chn args ret m h =>
HandlersT chn () ('Method name anns args ret : ms) m (h : hs)
-> (h -> HandlersT chn () ms m hs -> r) -> (Void# -> r) -> r
:<|>: xs <- (($ ()) -> x) :<||>: xs where
x :: h
x :<|>: xs :: HandlersT chn () ms m hs
xs = h -> () -> h
forall a b. a -> b -> a
noContext h
x (() -> h)
-> HandlersT chn () ms m hs
-> HandlersT chn () ('Method name anns args ret : ms) m (h : hs)
forall serviceName anm mnm (chn :: ServiceChain serviceName)
(args :: [Argument serviceName anm]) (ret :: Return serviceName)
(m :: * -> *) h inh (ms :: [Method serviceName mnm anm])
(hs :: [*]) (name :: mnm) (anns :: [*]).
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)
:<||>: HandlersT chn () ms m hs
xs
class Handles (chn :: ServiceChain snm)
(args :: [Argument snm anm]) (ret :: Return snm)
(m :: Type -> Type) (h :: Type)
class ToRef (chn :: ServiceChain snm)
(ref :: TypeRef snm) (t :: Type)
class FromRef (chn :: ServiceChain snm)
(ref :: TypeRef snm) (t :: Type)
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
instance (FromRef chn ref t, Handles chn args ret m h,
handler ~ (t -> 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 chn ('ArgStream aname anns ref ': args) ret m handler
instance (MonadError ServerError m, handler ~ m ())
=> 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
method :: forall n p. p -> Named n (() -> p)
method :: p -> Named n (() -> p)
method f :: p
f = (() -> p) -> Named n (() -> p)
forall k (n :: k) h. h -> Named n h
Named (\() -> p
f)
field :: forall n h. h -> Named n h
field :: h -> Named n h
field = h -> Named n h
forall k (n :: k) h. h -> Named n h
Named
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 :: p
-> ServerT
chn ('Package pname '[ 'Service sname sanns methods]) m '[hs]
singleService nl :: p
nl = HandlersT chn () methods m hs
-> ServerT
chn ('Package pname '[ 'Service sname sanns methods]) m '[hs]
forall serviceName mnm anm (chn :: Mappings serviceName *)
(sname :: serviceName) (methods :: [Method serviceName mnm anm])
(m :: * -> *) (hs :: [*]) (pname :: Maybe serviceName)
(sanns :: [*]).
(MappingRight chn sname ~ ()) =>
HandlersT chn () methods m hs
-> ServerT
chn ('Package pname '[ 'Service sname sanns methods]) m '[hs]
Server (HandlersT chn () methods m hs
-> ServerT
chn ('Package pname '[ 'Service sname sanns methods]) m '[hs])
-> HandlersT chn () methods m hs
-> ServerT
chn ('Package pname '[ 'Service sname sanns methods]) m '[hs]
forall a b. (a -> b) -> a -> b
$ NamedList nl -> HandlersT chn () methods m hs
forall snm mnm anm (chn :: ServiceChain snm) inh
(ms :: [Method snm mnm anm]) (m :: * -> *) (hs :: [*])
(nl :: [(Symbol, *)]).
ToHandlers chn inh ms m hs nl =>
NamedList nl -> HandlersT chn inh ms m hs
toHandlers (NamedList nl -> HandlersT chn () methods m hs)
-> NamedList nl -> HandlersT chn () methods m hs
forall a b. (a -> b) -> a -> b
$ p -> NamedList nl
forall p (nl :: [(Symbol, *)]).
ToNamedList p nl =>
p -> NamedList nl
toNamedList p
nl
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 :: p -> Named sname (HandlersT chn (MappingRight chn sname) ms m hs)
object nl :: p
nl = HandlersT chn (MappingRight chn sname) ms m hs
-> Named sname (HandlersT chn (MappingRight chn sname) ms m hs)
forall k (n :: k) h. h -> Named n h
Named (HandlersT chn (MappingRight chn sname) ms m hs
-> Named sname (HandlersT chn (MappingRight chn sname) ms m hs))
-> HandlersT chn (MappingRight chn sname) ms m hs
-> Named sname (HandlersT chn (MappingRight chn sname) ms m hs)
forall a b. (a -> b) -> a -> b
$ NamedList nl -> HandlersT chn (MappingRight chn sname) ms m hs
forall snm mnm anm (chn :: ServiceChain snm) inh
(ms :: [Method snm mnm anm]) (m :: * -> *) (hs :: [*])
(nl :: [(Symbol, *)]).
ToHandlers chn inh ms m hs nl =>
NamedList nl -> HandlersT chn inh ms m hs
toHandlers (NamedList nl -> HandlersT chn (MappingRight chn sname) ms m hs)
-> NamedList nl -> HandlersT chn (MappingRight chn sname) ms m hs
forall a b. (a -> b) -> a -> b
$ p -> NamedList nl
forall p (nl :: [(Symbol, *)]).
ToNamedList p nl =>
p -> NamedList nl
toNamedList p
nl
resolver
:: (ToNamedList p nl, ToServices chn ss m hs nl)
=> p -> ServerT chn ('Package pname ss) m hs
resolver :: p -> ServerT chn ('Package pname ss) m hs
resolver nl :: p
nl = ServicesT chn ss m hs -> ServerT chn ('Package pname ss) m hs
forall serviceName mnm anm (chn :: ServiceChain serviceName)
(s :: [Service serviceName mnm anm]) (m :: * -> *) (hs :: [[*]])
(pname :: Maybe serviceName).
ServicesT chn s m hs -> ServerT chn ('Package pname s) m hs
Services (ServicesT chn ss m hs -> ServerT chn ('Package pname ss) m hs)
-> ServicesT chn ss m hs -> ServerT chn ('Package pname ss) m hs
forall a b. (a -> b) -> a -> b
$ NamedList nl -> ServicesT chn ss m hs
forall snm mnm anm (chn :: ServiceChain snm)
(ss :: [Service snm mnm anm]) (m :: * -> *) (hs :: [[*]])
(nl :: [(Symbol, *)]).
ToServices chn ss m hs nl =>
NamedList nl -> ServicesT chn ss m hs
toServices (NamedList nl -> ServicesT chn ss m hs)
-> NamedList nl -> ServicesT chn ss m hs
forall a b. (a -> b) -> a -> b
$ p -> NamedList nl
forall p (nl :: [(Symbol, *)]).
ToNamedList p nl =>
p -> NamedList nl
toNamedList p
nl
data Named n h where
Named :: forall n h. h -> Named n h
infixr 4 :|:
data NamedList (hs :: [(Symbol, *)]) where
N0 :: NamedList '[]
(:|:) :: Named n h -> NamedList hs
-> NamedList ('(n, h) ': hs)
class ToNamedList p nl | p -> nl where
toNamedList :: p -> NamedList nl
instance ToNamedList (NamedList nl) nl where
toNamedList :: NamedList nl -> NamedList nl
toNamedList = NamedList nl -> NamedList nl
forall a. a -> a
id
instance ToNamedList () '[] where
toNamedList :: () -> NamedList '[]
toNamedList _ = NamedList '[]
N0
instance ToNamedList (Named n h) '[ '(n, h) ] where
toNamedList :: Named n h -> NamedList '[ '(n, h)]
toNamedList n :: Named n h
n = Named n h
n Named n h -> NamedList '[] -> NamedList '[ '(n, h)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: NamedList '[]
N0
instance ToNamedList (Named n1 h1, Named n2 h2)
'[ '(n1, h1), '(n2, h2) ] where
toNamedList :: (Named n1 h1, Named n2 h2) -> NamedList '[ '(n1, h1), '(n2, h2)]
toNamedList (n1 :: Named n1 h1
n1, n2 :: Named n2 h2
n2) = Named n1 h1
n1 Named n1 h1
-> NamedList '[ '(n2, h2)] -> NamedList '[ '(n1, h1), '(n2, h2)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n2 h2
n2 Named n2 h2 -> NamedList '[] -> NamedList '[ '(n2, h2)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: NamedList '[]
N0
instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3)
'[ '(n1, h1), '(n2, h2), '(n3, h3) ] where
toNamedList :: (Named n1 h1, Named n2 h2, Named n3 h3)
-> NamedList '[ '(n1, h1), '(n2, h2), '(n3, h3)]
toNamedList (n1 :: Named n1 h1
n1, n2 :: Named n2 h2
n2, n3 :: Named n3 h3
n3) = Named n1 h1
n1 Named n1 h1
-> NamedList '[ '(n2, h2), '(n3, h3)]
-> NamedList '[ '(n1, h1), '(n2, h2), '(n3, h3)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n2 h2
n2 Named n2 h2
-> NamedList '[ '(n3, h3)] -> NamedList '[ '(n2, h2), '(n3, h3)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n3 h3
n3 Named n3 h3 -> NamedList '[] -> NamedList '[ '(n3, h3)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: NamedList '[]
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 :: (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4)
-> NamedList '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4)]
toNamedList (n1 :: Named n1 h1
n1, n2 :: Named n2 h2
n2, n3 :: Named n3 h3
n3, n4 :: Named n4 h4
n4) = Named n1 h1
n1 Named n1 h1
-> NamedList '[ '(n2, h2), '(n3, h3), '(n4, h4)]
-> NamedList '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n2 h2
n2 Named n2 h2
-> NamedList '[ '(n3, h3), '(n4, h4)]
-> NamedList '[ '(n2, h2), '(n3, h3), '(n4, h4)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n3 h3
n3 Named n3 h3
-> NamedList '[ '(n4, h4)] -> NamedList '[ '(n3, h3), '(n4, h4)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n4 h4
n4 Named n4 h4 -> NamedList '[] -> NamedList '[ '(n4, h4)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: NamedList '[]
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 :: (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5)
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5)]
toNamedList (n1 :: Named n1 h1
n1, n2 :: Named n2 h2
n2, n3 :: Named n3 h3
n3, n4 :: Named n4 h4
n4, n5 :: Named n5 h5
n5) = Named n1 h1
n1 Named n1 h1
-> NamedList '[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5)]
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n2 h2
n2 Named n2 h2
-> NamedList '[ '(n3, h3), '(n4, h4), '(n5, h5)]
-> NamedList '[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n3 h3
n3 Named n3 h3
-> NamedList '[ '(n4, h4), '(n5, h5)]
-> NamedList '[ '(n3, h3), '(n4, h4), '(n5, h5)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n4 h4
n4 Named n4 h4
-> NamedList '[ '(n5, h5)] -> NamedList '[ '(n4, h4), '(n5, h5)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n5 h5
n5 Named n5 h5 -> NamedList '[] -> NamedList '[ '(n5, h5)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: NamedList '[]
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 :: (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5,
Named n6 h6)
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5),
'(n6, h6)]
toNamedList (n1 :: Named n1 h1
n1, n2 :: Named n2 h2
n2, n3 :: Named n3 h3
n3, n4 :: Named n4 h4
n4, n5 :: Named n5 h5
n5, n6 :: Named n6 h6
n6) = Named n1 h1
n1 Named n1 h1
-> NamedList
'[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6)]
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5),
'(n6, h6)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n2 h2
n2 Named n2 h2
-> NamedList '[ '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6)]
-> NamedList
'[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n3 h3
n3 Named n3 h3
-> NamedList '[ '(n4, h4), '(n5, h5), '(n6, h6)]
-> NamedList '[ '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n4 h4
n4 Named n4 h4
-> NamedList '[ '(n5, h5), '(n6, h6)]
-> NamedList '[ '(n4, h4), '(n5, h5), '(n6, h6)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n5 h5
n5 Named n5 h5
-> NamedList '[ '(n6, h6)] -> NamedList '[ '(n5, h5), '(n6, h6)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n6 h6
n6 Named n6 h6 -> NamedList '[] -> NamedList '[ '(n6, h6)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: NamedList '[]
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 :: (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5,
Named n6 h6, Named n7 h7)
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5),
'(n6, h6), '(n7, h7)]
toNamedList (n1 :: Named n1 h1
n1, n2 :: Named n2 h2
n2, n3 :: Named n3 h3
n3, n4 :: Named n4 h4
n4, n5 :: Named n5 h5
n5, n6 :: Named n6 h6
n6, n7 :: Named n7 h7
n7) = Named n1 h1
n1 Named n1 h1
-> NamedList
'[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6),
'(n7, h7)]
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5),
'(n6, h6), '(n7, h7)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n2 h2
n2 Named n2 h2
-> NamedList
'[ '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7)]
-> NamedList
'[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6),
'(n7, h7)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n3 h3
n3 Named n3 h3
-> NamedList '[ '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7)]
-> NamedList
'[ '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n4 h4
n4 Named n4 h4
-> NamedList '[ '(n5, h5), '(n6, h6), '(n7, h7)]
-> NamedList '[ '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n5 h5
n5 Named n5 h5
-> NamedList '[ '(n6, h6), '(n7, h7)]
-> NamedList '[ '(n5, h5), '(n6, h6), '(n7, h7)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n6 h6
n6 Named n6 h6
-> NamedList '[ '(n7, h7)] -> NamedList '[ '(n6, h6), '(n7, h7)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n7 h7
n7 Named n7 h7 -> NamedList '[] -> NamedList '[ '(n7, h7)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: NamedList '[]
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 :: (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5,
Named n6 h6, Named n7 h7, Named n8 h8)
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5),
'(n6, h6), '(n7, h7), '(n8, h8)]
toNamedList (n1 :: Named n1 h1
n1, n2 :: Named n2 h2
n2, n3 :: Named n3 h3
n3, n4 :: Named n4 h4
n4, n5 :: Named n5 h5
n5, n6 :: Named n6 h6
n6, n7 :: Named n7 h7
n7, n8 :: Named n8 h8
n8) = Named n1 h1
n1 Named n1 h1
-> NamedList
'[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6),
'(n7, h7), '(n8, h8)]
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5),
'(n6, h6), '(n7, h7), '(n8, h8)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n2 h2
n2 Named n2 h2
-> NamedList
'[ '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7),
'(n8, h8)]
-> NamedList
'[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6),
'(n7, h7), '(n8, h8)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n3 h3
n3 Named n3 h3
-> NamedList
'[ '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8)]
-> NamedList
'[ '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7),
'(n8, h8)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n4 h4
n4 Named n4 h4
-> NamedList '[ '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8)]
-> NamedList
'[ '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n5 h5
n5 Named n5 h5
-> NamedList '[ '(n6, h6), '(n7, h7), '(n8, h8)]
-> NamedList '[ '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n6 h6
n6 Named n6 h6
-> NamedList '[ '(n7, h7), '(n8, h8)]
-> NamedList '[ '(n6, h6), '(n7, h7), '(n8, h8)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n7 h7
n7 Named n7 h7
-> NamedList '[ '(n8, h8)] -> NamedList '[ '(n7, h7), '(n8, h8)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n8 h8
n8 Named n8 h8 -> NamedList '[] -> NamedList '[ '(n8, h8)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: NamedList '[]
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 :: (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)
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5),
'(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9)]
toNamedList (n1 :: Named n1 h1
n1, n2 :: Named n2 h2
n2, n3 :: Named n3 h3
n3, n4 :: Named n4 h4
n4, n5 :: Named n5 h5
n5, n6 :: Named n6 h6
n6, n7 :: Named n7 h7
n7, n8 :: Named n8 h8
n8, n9 :: Named n9 h9
n9) = Named n1 h1
n1 Named n1 h1
-> NamedList
'[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6),
'(n7, h7), '(n8, h8), '(n9, h9)]
-> NamedList
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5),
'(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n2 h2
n2 Named n2 h2
-> NamedList
'[ '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7),
'(n8, h8), '(n9, h9)]
-> NamedList
'[ '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6),
'(n7, h7), '(n8, h8), '(n9, h9)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n3 h3
n3 Named n3 h3
-> NamedList
'[ '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8),
'(n9, h9)]
-> NamedList
'[ '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7),
'(n8, h8), '(n9, h9)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n4 h4
n4 Named n4 h4
-> NamedList
'[ '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9)]
-> NamedList
'[ '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8),
'(n9, h9)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n5 h5
n5 Named n5 h5
-> NamedList '[ '(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9)]
-> NamedList
'[ '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n6 h6
n6 Named n6 h6
-> NamedList '[ '(n7, h7), '(n8, h8), '(n9, h9)]
-> NamedList '[ '(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n7 h7
n7 Named n7 h7
-> NamedList '[ '(n8, h8), '(n9, h9)]
-> NamedList '[ '(n7, h7), '(n8, h8), '(n9, h9)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n8 h8
n8 Named n8 h8
-> NamedList '[ '(n9, h9)] -> NamedList '[ '(n8, h8), '(n9, h9)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: Named n9 h9
n9 Named n9 h9 -> NamedList '[] -> NamedList '[ '(n9, h9)]
forall (n :: Symbol) h (hs :: [(Symbol, *)]).
Named n h -> NamedList hs -> NamedList ('(n, h) : hs)
:|: NamedList '[]
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 :: NamedList nl -> HandlersT chn inh '[] m '[]
toHandlers _ = HandlersT chn inh '[] m '[]
forall snm mnm anm (chn :: ServiceChain snm) inh (m :: * -> *).
HandlersT chn inh '[] m '[]
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 :: NamedList nl
-> HandlersT chn inh ('Method name anns args ret : ms) m (h : hs)
toHandlers nl :: NamedList nl
nl = Proxy name -> NamedList nl -> inh -> h
forall k (name :: k) inh h (nl :: [(Symbol, *)]).
FindHandler name inh h nl =>
Proxy name -> NamedList nl -> inh -> h
findHandler (Proxy name
forall k (t :: k). Proxy t
Proxy @name) NamedList nl
nl (inh -> h)
-> HandlersT chn inh ms m hs
-> HandlersT chn inh ('Method name anns args ret : ms) m (h : hs)
forall serviceName anm mnm (chn :: ServiceChain serviceName)
(args :: [Argument serviceName anm]) (ret :: Return serviceName)
(m :: * -> *) h inh (ms :: [Method serviceName mnm anm])
(hs :: [*]) (name :: mnm) (anns :: [*]).
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)
:<||>: NamedList nl -> HandlersT chn inh ms m hs
forall snm mnm anm (chn :: ServiceChain snm) inh
(ms :: [Method snm mnm anm]) (m :: * -> *) (hs :: [*])
(nl :: [(Symbol, *)]).
ToHandlers chn inh ms m hs nl =>
NamedList nl -> HandlersT chn inh ms m hs
toHandlers NamedList nl
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 :: Proxy name -> NamedList '[] -> inh -> h
findHandler = String -> Proxy name -> NamedList '[] -> inh -> h
forall a. HasCallStack => String -> a
error "this should never be called"
instance {-# OVERLAPS #-} (inh ~ inh', h ~ h')
=> FindHandler name inh h ( '(name, inh' -> h') ': rest ) where
findHandler :: Proxy name -> NamedList ('(name, inh' -> h') : rest) -> inh -> h
findHandler _ (Named f :: h
f :|: _) = h
inh -> h
f
instance {-# OVERLAPPABLE #-} FindHandler name inh h rest
=> FindHandler name inh h (thing ': rest) where
findHandler :: Proxy name -> NamedList (thing : rest) -> inh -> h
findHandler p :: Proxy name
p (_ :|: rest :: NamedList hs
rest) = Proxy name -> NamedList hs -> inh -> h
forall k (name :: k) inh h (nl :: [(Symbol, *)]).
FindHandler name inh h nl =>
Proxy name -> NamedList nl -> inh -> h
findHandler Proxy name
p NamedList hs
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 :: NamedList nl -> ServicesT chn '[] m '[]
toServices _ = ServicesT chn '[] m '[]
forall snm mnm anm (chn :: ServiceChain snm) (m :: * -> *).
ServicesT chn '[] m '[]
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 :: NamedList nl
-> ServicesT chn ('Service name anns methods : ss) m (h : hs)
toServices nl :: NamedList nl
nl = Proxy name
-> NamedList nl
-> HandlersT chn (MappingRight chn name) methods m h
forall k (name :: k) h (nl :: [(Symbol, *)]).
FindService name h nl =>
Proxy name -> NamedList nl -> h
findService (Proxy name
forall k (t :: k). Proxy t
Proxy @name) NamedList nl
nl HandlersT chn (MappingRight chn name) methods m h
-> ServicesT chn ss m hs
-> ServicesT chn ('Service name anns methods : ss) m (h : hs)
forall serviceName mnm anm (chn :: ServiceChain serviceName)
(sname :: serviceName) (methods :: [Method serviceName mnm anm])
(m :: * -> *) (hs :: [*]) (rest :: [Service serviceName mnm anm])
(hss :: [[*]]) (anns :: [*]).
HandlersT chn (MappingRight chn sname) methods m hs
-> ServicesT chn rest m hss
-> ServicesT chn ('Service sname anns methods : rest) m (hs : hss)
:<&>: NamedList nl -> ServicesT chn ss m hs
forall snm mnm anm (chn :: ServiceChain snm)
(ss :: [Service snm mnm anm]) (m :: * -> *) (hs :: [[*]])
(nl :: [(Symbol, *)]).
ToServices chn ss m hs nl =>
NamedList nl -> ServicesT chn ss m hs
toServices NamedList nl
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 :: Proxy name -> NamedList '[] -> h
findService = String -> Proxy name -> NamedList '[] -> h
forall a. HasCallStack => String -> a
error "this should never be called"
instance {-# OVERLAPS #-} (h ~ h')
=> FindService name h ( '(name, h') ': rest ) where
findService :: Proxy name -> NamedList ('(name, h') : rest) -> h
findService _ (Named f :: h
f :|: _) = h
h
f
instance {-# OVERLAPPABLE #-} FindService name h rest
=> FindService name h (thing ': rest) where
findService :: Proxy name -> NamedList (thing : rest) -> h
findService p :: Proxy name
p (_ :|: rest :: NamedList hs
rest) = Proxy name -> NamedList hs -> h
forall k (name :: k) h (nl :: [(Symbol, *)]).
FindService name h nl =>
Proxy name -> NamedList nl -> h
findService Proxy name
p NamedList hs
rest