diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 452e4d35..8d431765 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -30,6 +30,7 @@ source-repository head library exposed-modules: Servant.Client + Servant.Client.Generic Servant.Client.Experimental.Auth Servant.Common.BaseUrl Servant.Common.BasicAuth @@ -42,6 +43,7 @@ library , base64-bytestring >= 1.0.0.1 && < 1.1 , bytestring >= 0.10 && < 0.11 , exceptions >= 0.8 && < 0.9 + , generics-sop , http-api-data >= 0.3 && < 0.4 , http-client >= 0.4.18.1 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 diff --git a/servant-client/src/Servant/Client/Generic.hs b/servant-client/src/Servant/Client/Generic.hs new file mode 100644 index 00000000..138e769d --- /dev/null +++ b/servant-client/src/Servant/Client/Generic.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Client.Generic + ( ClientLike(..) + , genericMkClient + ) where + +import Generics.SOP (Generic, I(..), NP(..), NS(Z), Rep, SOP(..), to) +import Servant.API ((:<|>)(..)) +import Servant.Client (ClientM) + +-- | This class allows us to match client structure with client functions +-- produced with 'client' without explicit pattern-matching. +-- +-- The client structure needs a 'Generics.SOP.Generic' instance. +-- +-- Example: +-- +-- type API +-- = "foo" :> Capture "x" Int :> Get '[JSON] Int +-- :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int] +-- :<|> Captre "nested" Int :> NestedAPI +-- +-- type NestedAPI +-- = Get '[JSON] String +-- :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] () +-- +-- data APIClient = APIClient +-- { getFoo :: Int -> Manager -> BaseUrl -> ClientM Int +-- , postBar :: Maybe Char -> Maybe String -> Manager -> BaseUrl -> ClientM [Int] +-- , mkNestedClient :: Int -> NestedClient +-- } deriving GHC.Generic +-- +-- instance Generic.SOP.Generic APIClient +-- instance (Client API ~ client) => ClientLike client APIClient +-- +-- data NestedClient = NestedClient +-- { getString :: Manager -> BaseUrl -> ClientM String +-- , postBaz :: Maybe Char -> Manager -> BaseUrl -> ClientM () +-- } deriving GHC.Generic +-- +-- instance Generic.SOP.Generic +-- instance (Client NestedAPI ~ client) => ClientLike client NestedAPI +-- +-- 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) + => client -> custom + mkClient = genericMkClient + +instance ClientLike client custom + => ClientLike (a -> client) (a -> custom) where + mkClient c = mkClient . c + +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. +class GClientLikeP client xs where + gMkClientP :: client -> NP I xs + +instance (GClientLikeP b (y ': xs), ClientLike a x) + => GClientLikeP (a :<|> b) (x ': y ': xs) where + gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b + +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 +