Expand left-nested APIs by default

Author: Catherine Galkina

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
 
+-- 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.
-genericMkClient :: (Generic custom, GClientLikeP client xs, SOP I '[xs] ~ Rep custom)
+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
-genericMkClient = to . SOP . Z . gMkClientP
+genericMkClientP = to . SOP . Z . gMkClientP