git.iko.soy/typeable/servant
on master help sign in
Merge pull request #265 from liqd/foreign-internal-module
8bf804eJulian Arni
servant-foreign/servant-foreign.cabal+1−1
compare with master
unifiedsplit
@@ -25,7 +25,7 @@ source-repository head
25 location: http://github.com/haskell-servant/servant.git
25 location: http://github.com/haskell-servant/servant.git
26
26
27library
27library
28− exposed-modules: Servant.Foreign
28+ exposed-modules: Servant.Foreign, Servant.Foreign.Internal
29 build-depends: base == 4.*
29 build-depends: base == 4.*
30 , lens == 4.*
30 , lens == 4.*
31 , servant == 0.5.*
31 , servant == 0.5.*
servant-foreign/src/Servant/Foreign.hs+2−257
@@ -1,19 +1,3 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−#if !MIN_VERSION_base(4,8,0)
7−{-# LANGUAGE NullaryTypeClasses #-}
8−#endif
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TemplateHaskell #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−{-# LANGUAGE OverloadedStrings #-}
16−
17-- | Generalizes all the data needed to make code generation work with
1-- | Generalizes all the data needed to make code generation work with
18-- arbitrary programming languages.
2-- arbitrary programming languages.
19module Servant.Foreign
3module Servant.Foreign
@@ -46,244 +30,5 @@ module Servant.Foreign
46 , module Servant.API
30 , module Servant.API
47 ) where
31 ) where
48
32
49−import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
50−import qualified Data.Char as C
51−import Data.Proxy
52−import Data.Text
53−import GHC.Exts (Constraint)
54−import GHC.TypeLits
55−import Prelude hiding (concat)
56−import Servant.API
33+import Servant.API
57−
34+import Servant.Foreign.Internal
58−-- | Function name builder that simply concat each part together
59−concatCase :: FunctionName -> Text
60−concatCase = concat
61−
62−-- | Function name builder using the snake_case convention.
63−-- each part is separated by a single underscore character.
64−snakeCase :: FunctionName -> Text
65−snakeCase = intercalate "_"
66−
67−-- | Function name builder using the CamelCase convention.
68−-- each part begins with an upper case character.
69−camelCase :: FunctionName -> Text
70−camelCase = camelCase' . Prelude.map (replace "-" "")
71− where camelCase' [] = ""
72− camelCase' (p:ps) = concat $ p : Prelude.map capitalize ps
73− capitalize "" = ""
74− capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name
75−
76−type Arg = Text
77−
78−newtype Segment = Segment { _segment :: SegmentType }
79− deriving (Eq, Show)
80−
81−data SegmentType = Static Text -- ^ a static path segment. like "/foo"
82− | Cap Arg -- ^ a capture. like "/:userid"
83− deriving (Eq, Show)
84−
85−type Path = [Segment]
86−
87−data ArgType =
88− Normal
89− | Flag
90− | List
91− deriving (Eq, Show)
92−
93−data QueryArg = QueryArg
94− { _argName :: Arg
95− , _argType :: ArgType
96− } deriving (Eq, Show)
97−
98−data HeaderArg = HeaderArg
99− { headerArgName :: Text
100− }
101− | ReplaceHeaderArg
102− { headerArgName :: Text
103− , headerPattern :: Text
104− } deriving (Eq, Show)
105−
106−
107−data Url = Url
108− { _path :: Path
109− , _queryStr :: [QueryArg]
110− } deriving (Eq, Show)
111−
112−defUrl :: Url
113−defUrl = Url [] []
114−
115−type FunctionName = [Text]
116−type Method = Text
117−
118−data Req = Req
119− { _reqUrl :: Url
120− , _reqMethod :: Method
121− , _reqHeaders :: [HeaderArg]
122− , _reqBody :: Bool
123− , _funcName :: FunctionName
124− } deriving (Eq, Show)
125−
126−makeLenses ''QueryArg
127−makeLenses ''Segment
128−makeLenses ''Url
129−makeLenses ''Req
130−
131−isCapture :: Segment -> Bool
132−isCapture (Segment (Cap _)) = True
133−isCapture _ = False
134−
135−captureArg :: Segment -> Arg
136−captureArg (Segment (Cap s)) = s
137−captureArg _ = error "captureArg called on non capture"
138−
139−defReq :: Req
140−defReq = Req defUrl "GET" [] False []
141−
142−-- | To be used exclusively as a "negative" return type/constraint
143−-- by @'Elem`@ type family.
144−class NotFound
145−
146−type family Elem (a :: *) (ls::[*]) :: Constraint where
147− Elem a '[] = NotFound
148− Elem a (a ': list) = ()
149− Elem a (b ': list) = Elem a list
150−
151−class HasForeign (layout :: *) where
152− type Foreign layout :: *
153− foreignFor :: Proxy layout -> Req -> Foreign layout
154−
155−instance (HasForeign a, HasForeign b)
156− => HasForeign (a :<|> b) where
157− type Foreign (a :<|> b) = Foreign a :<|> Foreign b
158−
159− foreignFor Proxy req =
160− foreignFor (Proxy :: Proxy a) req
161− :<|> foreignFor (Proxy :: Proxy b) req
162−
163−instance (KnownSymbol sym, HasForeign sublayout)
164− => HasForeign (Capture sym a :> sublayout) where
165− type Foreign (Capture sym a :> sublayout) = Foreign sublayout
166−
167− foreignFor Proxy req =
168− foreignFor (Proxy :: Proxy sublayout) $
169− req & reqUrl.path <>~ [Segment (Cap str)]
170− & funcName %~ (++ ["by", str])
171−
172− where str = pack . symbolVal $ (Proxy :: Proxy sym)
173−
174−instance Elem JSON list => HasForeign (Delete list a) where
175− type Foreign (Delete list a) = Req
176−
177− foreignFor Proxy req =
178− req & funcName %~ ("delete" :)
179− & reqMethod .~ "DELETE"
180−
181−instance Elem JSON list => HasForeign (Get list a) where
182− type Foreign (Get list a) = Req
183−
184− foreignFor Proxy req =
185− req & funcName %~ ("get" :)
186− & reqMethod .~ "GET"
187−
188−instance (KnownSymbol sym, HasForeign sublayout)
189− => HasForeign (Header sym a :> sublayout) where
190− type Foreign (Header sym a :> sublayout) = Foreign sublayout
191−
192− foreignFor Proxy req =
193− foreignFor subP (req & reqHeaders <>~ [HeaderArg hname])
194−
195− where hname = pack . symbolVal $ (Proxy :: Proxy sym)
196− subP = Proxy :: Proxy sublayout
197−
198−instance Elem JSON list => HasForeign (Post list a) where
199− type Foreign (Post list a) = Req
200−
201− foreignFor Proxy req =
202− req & funcName %~ ("post" :)
203− & reqMethod .~ "POST"
204−
205−instance Elem JSON list => HasForeign (Put list a) where
206− type Foreign (Put list a) = Req
207−
208− foreignFor Proxy req =
209− req & funcName %~ ("put" :)
210− & reqMethod .~ "PUT"
211−
212−instance (KnownSymbol sym, HasForeign sublayout)
213− => HasForeign (QueryParam sym a :> sublayout) where
214− type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
215−
216− foreignFor Proxy req =
217− foreignFor (Proxy :: Proxy sublayout) $
218− req & reqUrl.queryStr <>~ [QueryArg str Normal]
219−
220− where str = pack . symbolVal $ (Proxy :: Proxy sym)
221−
222−instance (KnownSymbol sym, HasForeign sublayout)
223− => HasForeign (QueryParams sym a :> sublayout) where
224− type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout
225−
226− foreignFor Proxy req =
227− foreignFor (Proxy :: Proxy sublayout) $
228− req & reqUrl.queryStr <>~ [QueryArg str List]
229−
230− where str = pack . symbolVal $ (Proxy :: Proxy sym)
231−
232−instance (KnownSymbol sym, HasForeign sublayout)
233− => HasForeign (QueryFlag sym :> sublayout) where
234− type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout
235−
236− foreignFor Proxy req =
237− foreignFor (Proxy :: Proxy sublayout) $
238− req & reqUrl.queryStr <>~ [QueryArg str Flag]
239−
240− where str = pack . symbolVal $ (Proxy :: Proxy sym)
241−
242−instance HasForeign Raw where
243− type Foreign Raw = Method -> Req
244−
245− foreignFor Proxy req method =
246− req & funcName %~ ((toLower method) :)
247− & reqMethod .~ method
248−
249−instance (Elem JSON list, HasForeign sublayout) => HasForeign (ReqBody list a :> sublayout) where
250− type Foreign (ReqBody list a :> sublayout) = Foreign sublayout
251−
252− foreignFor Proxy req =
253− foreignFor (Proxy :: Proxy sublayout) $
254− req & reqBody .~ True
255−
256−instance (KnownSymbol path, HasForeign sublayout)
257− => HasForeign (path :> sublayout) where
258− type Foreign (path :> sublayout) = Foreign sublayout
259−
260− foreignFor Proxy req =
261− foreignFor (Proxy :: Proxy sublayout) $
262− req & reqUrl.path <>~ [Segment (Static str)]
263− & funcName %~ (++ [str])
264−
265− where str = Data.Text.map (\c -> if c == '.' then '_' else c) . pack . symbolVal $ (Proxy :: Proxy path)
266−
267−instance HasForeign sublayout => HasForeign (RemoteHost :> sublayout) where
268− type Foreign (RemoteHost :> sublayout) = Foreign sublayout
269−
270− foreignFor Proxy req =
271− foreignFor (Proxy :: Proxy sublayout) req
272−
273−instance HasForeign sublayout => HasForeign (IsSecure :> sublayout) where
274− type Foreign (IsSecure :> sublayout) = Foreign sublayout
275−
276− foreignFor Proxy req =
277− foreignFor (Proxy :: Proxy sublayout) req
278−
279−instance HasForeign sublayout => HasForeign (Vault :> sublayout) where
280− type Foreign (Vault :> sublayout) = Foreign sublayout
281−
282− foreignFor Proxy req =
283− foreignFor (Proxy :: Proxy sublayout) req
284−
285−instance HasForeign sublayout => HasForeign (HttpVersion :> sublayout) where
286− type Foreign (HttpVersion :> sublayout) = Foreign sublayout
287−
288− foreignFor Proxy req =
289− foreignFor (Proxy :: Proxy sublayout) req
servant-foreign/src/Servant/Foreign/Internal.hsnew file+261
@@ -0,0 +1,261 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+#if !MIN_VERSION_base(4,8,0)
7+{-# LANGUAGE NullaryTypeClasses #-}
8+#endif
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TemplateHaskell #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
15+{-# LANGUAGE OverloadedStrings #-}
16+
17+-- | Generalizes all the data needed to make code generation work with
18+-- arbitrary programming languages.
19+module Servant.Foreign.Internal where
20+
21+import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
22+import qualified Data.Char as C
23+import Data.Proxy
24+import Data.Text
25+import GHC.Exts (Constraint)
26+import GHC.TypeLits
27+import Prelude hiding (concat)
28+import Servant.API
29+
30+-- | Function name builder that simply concat each part together
31+concatCase :: FunctionName -> Text
32+concatCase = concat
33+
34+-- | Function name builder using the snake_case convention.
35+-- each part is separated by a single underscore character.
36+snakeCase :: FunctionName -> Text
37+snakeCase = intercalate "_"
38+
39+-- | Function name builder using the CamelCase convention.
40+-- each part begins with an upper case character.
41+camelCase :: FunctionName -> Text
42+camelCase = camelCase' . Prelude.map (replace "-" "")
43+ where camelCase' [] = ""
44+ camelCase' (p:ps) = concat $ p : Prelude.map capitalize ps
45+ capitalize "" = ""
46+ capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name
47+
48+type Arg = Text
49+
50+newtype Segment = Segment { _segment :: SegmentType }
51+ deriving (Eq, Show)
52+
53+data SegmentType = Static Text -- ^ a static path segment. like "/foo"
54+ | Cap Arg -- ^ a capture. like "/:userid"
55+ deriving (Eq, Show)
56+
57+type Path = [Segment]
58+
59+data ArgType =
60+ Normal
61+ | Flag
62+ | List
63+ deriving (Eq, Show)
64+
65+data QueryArg = QueryArg
66+ { _argName :: Arg
67+ , _argType :: ArgType
68+ } deriving (Eq, Show)
69+
70+data HeaderArg = HeaderArg
71+ { headerArgName :: Text
72+ }
73+ | ReplaceHeaderArg
74+ { headerArgName :: Text
75+ , headerPattern :: Text
76+ } deriving (Eq, Show)
77+
78+
79+data Url = Url
80+ { _path :: Path
81+ , _queryStr :: [QueryArg]
82+ } deriving (Eq, Show)
83+
84+defUrl :: Url
85+defUrl = Url [] []
86+
87+type FunctionName = [Text]
88+type Method = Text
89+
90+data Req = Req
91+ { _reqUrl :: Url
92+ , _reqMethod :: Method
93+ , _reqHeaders :: [HeaderArg]
94+ , _reqBody :: Bool
95+ , _funcName :: FunctionName
96+ } deriving (Eq, Show)
97+
98+makeLenses ''QueryArg
99+makeLenses ''Segment
100+makeLenses ''Url
101+makeLenses ''Req
102+
103+isCapture :: Segment -> Bool
104+isCapture (Segment (Cap _)) = True
105+isCapture _ = False
106+
107+captureArg :: Segment -> Arg
108+captureArg (Segment (Cap s)) = s
109+captureArg _ = error "captureArg called on non capture"
110+
111+defReq :: Req
112+defReq = Req defUrl "GET" [] False []
113+
114+-- | To be used exclusively as a "negative" return type/constraint
115+-- by @'Elem`@ type family.
116+class NotFound
117+
118+type family Elem (a :: *) (ls::[*]) :: Constraint where
119+ Elem a '[] = NotFound
120+ Elem a (a ': list) = ()
121+ Elem a (b ': list) = Elem a list
122+
123+class HasForeign (layout :: *) where
124+ type Foreign layout :: *
125+ foreignFor :: Proxy layout -> Req -> Foreign layout
126+
127+instance (HasForeign a, HasForeign b)
128+ => HasForeign (a :<|> b) where
129+ type Foreign (a :<|> b) = Foreign a :<|> Foreign b
130+
131+ foreignFor Proxy req =
132+ foreignFor (Proxy :: Proxy a) req
133+ :<|> foreignFor (Proxy :: Proxy b) req
134+
135+instance (KnownSymbol sym, HasForeign sublayout)
136+ => HasForeign (Capture sym a :> sublayout) where
137+ type Foreign (Capture sym a :> sublayout) = Foreign sublayout
138+
139+ foreignFor Proxy req =
140+ foreignFor (Proxy :: Proxy sublayout) $
141+ req & reqUrl.path <>~ [Segment (Cap str)]
142+ & funcName %~ (++ ["by", str])
143+
144+ where str = pack . symbolVal $ (Proxy :: Proxy sym)
145+
146+instance Elem JSON list => HasForeign (Delete list a) where
147+ type Foreign (Delete list a) = Req
148+
149+ foreignFor Proxy req =
150+ req & funcName %~ ("delete" :)
151+ & reqMethod .~ "DELETE"
152+
153+instance Elem JSON list => HasForeign (Get list a) where
154+ type Foreign (Get list a) = Req
155+
156+ foreignFor Proxy req =
157+ req & funcName %~ ("get" :)
158+ & reqMethod .~ "GET"
159+
160+instance (KnownSymbol sym, HasForeign sublayout)
161+ => HasForeign (Header sym a :> sublayout) where
162+ type Foreign (Header sym a :> sublayout) = Foreign sublayout
163+
164+ foreignFor Proxy req =
165+ foreignFor subP (req & reqHeaders <>~ [HeaderArg hname])
166+
167+ where hname = pack . symbolVal $ (Proxy :: Proxy sym)
168+ subP = Proxy :: Proxy sublayout
169+
170+instance Elem JSON list => HasForeign (Post list a) where
171+ type Foreign (Post list a) = Req
172+
173+ foreignFor Proxy req =
174+ req & funcName %~ ("post" :)
175+ & reqMethod .~ "POST"
176+
177+instance Elem JSON list => HasForeign (Put list a) where
178+ type Foreign (Put list a) = Req
179+
180+ foreignFor Proxy req =
181+ req & funcName %~ ("put" :)
182+ & reqMethod .~ "PUT"
183+
184+instance (KnownSymbol sym, HasForeign sublayout)
185+ => HasForeign (QueryParam sym a :> sublayout) where
186+ type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
187+
188+ foreignFor Proxy req =
189+ foreignFor (Proxy :: Proxy sublayout) $
190+ req & reqUrl.queryStr <>~ [QueryArg str Normal]
191+
192+ where str = pack . symbolVal $ (Proxy :: Proxy sym)
193+
194+instance (KnownSymbol sym, HasForeign sublayout)
195+ => HasForeign (QueryParams sym a :> sublayout) where
196+ type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout
197+
198+ foreignFor Proxy req =
199+ foreignFor (Proxy :: Proxy sublayout) $
200+ req & reqUrl.queryStr <>~ [QueryArg str List]
201+
202+ where str = pack . symbolVal $ (Proxy :: Proxy sym)
203+
204+instance (KnownSymbol sym, HasForeign sublayout)
205+ => HasForeign (QueryFlag sym :> sublayout) where
206+ type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout
207+
208+ foreignFor Proxy req =
209+ foreignFor (Proxy :: Proxy sublayout) $
210+ req & reqUrl.queryStr <>~ [QueryArg str Flag]
211+
212+ where str = pack . symbolVal $ (Proxy :: Proxy sym)
213+
214+instance HasForeign Raw where
215+ type Foreign Raw = Method -> Req
216+
217+ foreignFor Proxy req method =
218+ req & funcName %~ ((toLower method) :)
219+ & reqMethod .~ method
220+
221+instance (Elem JSON list, HasForeign sublayout) => HasForeign (ReqBody list a :> sublayout) where
222+ type Foreign (ReqBody list a :> sublayout) = Foreign sublayout
223+
224+ foreignFor Proxy req =
225+ foreignFor (Proxy :: Proxy sublayout) $
226+ req & reqBody .~ True
227+
228+instance (KnownSymbol path, HasForeign sublayout)
229+ => HasForeign (path :> sublayout) where
230+ type Foreign (path :> sublayout) = Foreign sublayout
231+
232+ foreignFor Proxy req =
233+ foreignFor (Proxy :: Proxy sublayout) $
234+ req & reqUrl.path <>~ [Segment (Static str)]
235+ & funcName %~ (++ [str])
236+
237+ where str = Data.Text.map (\c -> if c == '.' then '_' else c) . pack . symbolVal $ (Proxy :: Proxy path)
238+
239+instance HasForeign sublayout => HasForeign (RemoteHost :> sublayout) where
240+ type Foreign (RemoteHost :> sublayout) = Foreign sublayout
241+
242+ foreignFor Proxy req =
243+ foreignFor (Proxy :: Proxy sublayout) req
244+
245+instance HasForeign sublayout => HasForeign (IsSecure :> sublayout) where
246+ type Foreign (IsSecure :> sublayout) = Foreign sublayout
247+
248+ foreignFor Proxy req =
249+ foreignFor (Proxy :: Proxy sublayout) req
250+
251+instance HasForeign sublayout => HasForeign (Vault :> sublayout) where
252+ type Foreign (Vault :> sublayout) = Foreign sublayout
253+
254+ foreignFor Proxy req =
255+ foreignFor (Proxy :: Proxy sublayout) req
256+
257+instance HasForeign sublayout => HasForeign (HttpVersion :> sublayout) where
258+ type Foreign (HttpVersion :> sublayout) = Foreign sublayout
259+
260+ foreignFor Proxy req =
261+ foreignFor (Proxy :: Proxy sublayout) req