@@ -0,0 +1,164 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DefaultSignatures #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+#include "overlapping-compat.h"
12+
13+module Servant.Client.Generic
14+ ( ClientLike(..)
15+ , genericMkClientL
16+ , genericMkClientP
17+ ) where
18+
19+import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to)
20+import Servant.API ((:<|>)(..))
21+import Servant.Client (ClientM)
22+
23+-- | This class allows us to match client structure with client functions
24+-- produced with 'client' without explicit pattern-matching.
25+--
26+-- The client structure needs a 'Generics.SOP.Generic' instance.
27+--
28+-- Example:
29+--
30+-- > type API
31+-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
32+-- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]
33+-- > :<|> Capture "nested" Int :> NestedAPI
34+-- >
35+-- > type NestedAPI
36+-- > = Get '[JSON] String
37+-- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()
38+-- >
39+-- > data APIClient = APIClient
40+-- > { getFoo :: Int -> ClientM Int
41+-- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int]
42+-- > , mkNestedClient :: Int -> NestedClient
43+-- > } deriving GHC.Generic
44+-- >
45+-- > instance Generics.SOP.Generic APIClient
46+-- > instance (Client API ~ client) => ClientLike client APIClient
47+-- >
48+-- > data NestedClient = NestedClient
49+-- > { getString :: ClientM String
50+-- > , postBaz :: Maybe Char -> ClientM ()
51+-- > } deriving GHC.Generic
52+-- >
53+-- > instance Generics.SOP.Generic NestedClient
54+-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient
55+-- >
56+-- > mkAPIClient :: APIClient
57+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
58+--
59+-- By default, left-nested alternatives are expanded:
60+--
61+-- > type API1
62+-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
63+-- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String
64+-- >
65+-- > type API2
66+-- > = "baz" :> QueryParam "c" Char :> Post '[JSON] ()
67+-- >
68+-- > type API = API1 :<|> API2
69+-- >
70+-- > data APIClient = APIClient
71+-- > { getFoo :: Int -> ClientM Int
72+-- > , postBar :: Maybe Char -> ClientM String
73+-- > , postBaz :: Maybe Char -> ClientM ()
74+-- > } deriving GHC.Generic
75+-- >
76+-- > instance Generics.SOP.Generic APIClient
77+-- > instance (Client API ~ client) => ClientLike client APIClient
78+-- >
79+-- > mkAPIClient :: APIClient
80+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
81+--
82+-- If you want to define client for @API1@ as a separate data structure,
83+-- you can use 'genericMkClientP':
84+--
85+-- > data APIClient1 = APIClient1
86+-- > { getFoo :: Int -> ClientM Int
87+-- > , postBar :: Maybe Char -> ClientM String
88+-- > } deriving GHC.Generic
89+-- >
90+-- > instance Generics.SOP.Generic APIClient1
91+-- > instance (Client API1 ~ client) => ClientLike client APIClient1
92+-- >
93+-- > data APIClient = APIClient
94+-- > { mkAPIClient1 :: APIClient1
95+-- > , postBaz :: Maybe Char -> ClientM ()
96+-- > } deriving GHC.Generic
97+-- >
98+-- > instance Generics.SOP.Generic APIClient
99+-- > instance (Client API ~ client) => ClientLike client APIClient where
100+-- > mkClient = genericMkClientP
101+-- >
102+-- > mkAPIClient :: APIClient
103+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
104+class ClientLike client custom where
105+ mkClient :: client -> custom
106+ default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
107+ => client -> custom
108+ mkClient = genericMkClientL
109+
110+instance ClientLike client custom
111+ => ClientLike (a -> client) (a -> custom) where
112+ mkClient c = mkClient . c
113+
114+instance ClientLike (ClientM a) (ClientM a) where
115+ mkClient = id
116+
117+-- | Match client structure with client functions, regarding left-nested API clients
118+-- as separate data structures.
119+class GClientLikeP client xs where
120+ gMkClientP :: client -> NP I xs
121+
122+instance (GClientLikeP b (y ': xs), ClientLike a x)
123+ => GClientLikeP (a :<|> b) (x ': y ': xs) where
124+ gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b
125+
126+instance ClientLike a x => GClientLikeP a '[x] where
127+ gMkClientP a = I (mkClient a) :* Nil
128+
129+-- | Match client structure with client functions, expanding left-nested API clients
130+-- in the same structure.
131+class GClientLikeL (xs :: [*]) (ys :: [*]) where
132+ gMkClientL :: NP I xs -> NP I ys
133+
134+instance GClientLikeL '[] '[] where
135+ gMkClientL Nil = Nil
136+
137+instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where
138+ gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs
139+
140+type family ClientList (client :: *) (acc :: [*]) :: [*] where
141+ ClientList (a :<|> b) acc = ClientList a (ClientList b acc)
142+ ClientList a acc = a ': acc
143+
144+class GClientList client (acc :: [*]) where
145+ gClientList :: client -> NP I acc -> NP I (ClientList client acc)
146+
147+instance (GClientList b acc, GClientList a (ClientList b acc))
148+ => GClientList (a :<|> b) acc where
149+ gClientList (a :<|> b) acc = gClientList a (gClientList b acc)
150+
151+instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc))
152+ => GClientList client acc where
153+ gClientList c acc = I c :* acc
154+
155+-- | Generate client structure from client type, expanding left-nested API (done by default).
156+genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
157+ => client -> custom
158+genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil
159+
160+-- | Generate client structure from client type, regarding left-nested API clients as separate data structures.
161+genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)
162+ => client -> custom
163+genericMkClientP = to . SOP . Z . gMkClientP
164+