diff --git a/servant-client/src/Servant/Client/Generic.hs b/servant-client/src/Servant/Client/Generic.hs index 45a832e2..5e577663 100644 --- a/servant-client/src/Servant/Client/Generic.hs +++ b/servant-client/src/Servant/Client/Generic.hs @@ -5,12 +5,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.Client.Generic ( ClientLike(..) - , genericMkClient + , genericMkClientL + , genericMkClientP ) where -import Generics.SOP (Generic, I(..), NP(..), NS(Z), Rep, SOP(..), to) +import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), Rep, SOP(..), to) import Servant.API ((:<|>)(..)) import Servant.Client (ClientM) @@ -40,20 +42,20 @@ import Servant.Client (ClientM) -- > instance (Client API ~ client) => ClientLike client APIClient -- > -- > data NestedClient = NestedClient --- > { getString :: ClientM String +-- > { getString :: ClientM String -- > , postBaz :: Maybe Char -> ClientM () -- > } deriving GHC.Generic -- > --- > instance Generic.SOP.Generic +-- > instance Generic.SOP.Generic NestedClient -- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient -- > -- > mkAPIClient :: APIClient -- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) class ClientLike client custom where mkClient :: client -> custom - default mkClient :: (Generic custom, GClientLikeP client xs, SOP I '[xs] ~ Rep custom) + default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) => client -> custom - mkClient = genericMkClient + mkClient = genericMkClientL instance ClientLike client custom => ClientLike (a -> client) (a -> custom) where @@ -62,9 +64,7 @@ instance ClientLike client custom instance ClientLike (ClientM a) (ClientM a) where mkClient = id --- | This class is used to match client functions to the --- representation of client structure type as sum of products --- and basically does all the internal job to build this structure. +-- GClientLikeP class GClientLikeP client xs where gMkClientP :: client -> NP I xs @@ -75,8 +75,37 @@ instance (GClientLikeP b (y ': xs), ClientLike a x) instance ClientLike a x => GClientLikeP a '[x] where gMkClientP a = I (mkClient a) :* Nil --- | Generate client structure from client type. -genericMkClient :: (Generic custom, GClientLikeP client xs, SOP I '[xs] ~ Rep custom) - => client -> custom -genericMkClient = to . SOP . Z . gMkClientP +-- GClientLikeL +class GClientLikeL (xs :: [*]) (ys :: [*]) where + gMkClientL :: NP I xs -> NP I ys + +instance GClientLikeL '[] '[] where + gMkClientL Nil = Nil + +instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where + gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs + +type family ClientList (client :: *) (acc :: [*]) :: [*] where + ClientList (a :<|> b) acc = ClientList a (ClientList b acc) + ClientList a acc = a ': acc + +class GClientList client (acc :: [*]) where + gClientList :: client -> NP I acc -> NP I (ClientList client acc) + +instance (GClientList b acc, GClientList a (ClientList b acc)) + => GClientList (a :<|> b) acc where + gClientList (a :<|> b) acc = gClientList a (gClientList b acc) + +instance {-# OVERLAPPABLE #-} (ClientList client acc ~ (client ': acc)) + => GClientList client acc where + gClientList c acc = I c :* acc + +-- | Generate client structure from client type. +genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) + => client -> custom +genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil + +genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs) + => client -> custom +genericMkClientP = to . SOP . Z . gMkClientP