git.iko.soy/typeable/servant
on master help sign in
Merge pull request #378 from haskell-servant/textly-typed
e34003eDenis Redozubov
servant-foreign/servant-foreign.cabal+30−3
compare with master
unifiedsplit
@@ -26,7 +26,9 @@ source-repository head
26 location: http://github.com/haskell-servant/servant.git
26 location: http://github.com/haskell-servant/servant.git
27
27
28library
28library
29− exposed-modules: Servant.Foreign, Servant.Foreign.Internal
29+ exposed-modules: Servant.Foreign
30+ , Servant.Foreign.Internal
31+ , Servant.Foreign.Inflections
30 build-depends: base == 4.*
32 build-depends: base == 4.*
31 , lens == 4.*
33 , lens == 4.*
32 , servant == 0.5.*
34 , servant == 0.5.*
@@ -36,6 +38,20 @@ library
36 default-language: Haskell2010
38 default-language: Haskell2010
37 ghc-options: -Wall
39 ghc-options: -Wall
38 include-dirs: include
40 include-dirs: include
41+ default-extensions: CPP
42+ , ConstraintKinds
43+ , DataKinds
44+ , FlexibleContexts
45+ , FlexibleInstances
46+ , GeneralizedNewtypeDeriving
47+ , MultiParamTypeClasses
48+ , ScopedTypeVariables
49+ , TemplateHaskell
50+ , TypeFamilies
51+ , TypeOperators
52+ , UndecidableInstances
53+ , OverloadedStrings
54+ , PolyKinds
39
55
40
56
41test-suite spec
57test-suite spec
@@ -44,9 +60,20 @@ test-suite spec
44 ghc-options: -Wall
60 ghc-options: -Wall
45 include-dirs: include
61 include-dirs: include
46 main-is: Spec.hs
62 main-is: Spec.hs
47− other-modules:
48− Servant.ForeignSpec
63+ other-modules: Servant.ForeignSpec
49 build-depends: base
64 build-depends: base
50 , hspec >= 2.1.8
65 , hspec >= 2.1.8
51 , servant-foreign
66 , servant-foreign
52 default-language: Haskell2010
67 default-language: Haskell2010
68+ default-extensions: ConstraintKinds
69+ , DataKinds
70+ , FlexibleContexts
71+ , FlexibleInstances
72+ , GeneralizedNewtypeDeriving
73+ , MultiParamTypeClasses
74+ , ScopedTypeVariables
75+ , TypeFamilies
76+ , TypeOperators
77+ , UndecidableInstances
78+ , OverloadedStrings
79+ , PolyKinds
servant-foreign/src/Servant/Foreign.hs+13−7
@@ -10,10 +10,14 @@ module Servant.Foreign
10 , Url(..)
10 , Url(..)
11 -- aliases
11 -- aliases
12 , Path
12 , Path
13− , ForeignType
13+ , ForeignType(..)
14− , Arg
14+ , Arg(..)
15− , FunctionName
15+ , FunctionName(..)
16+ , PathSegment(..)
16 -- lenses
17 -- lenses
18+ , aName
19+ , aType
20+ , aPath
17 , reqUrl
21 , reqUrl
18 , reqMethod
22 , reqMethod
19 , reqHeaders
23 , reqHeaders
@@ -24,7 +28,10 @@ module Servant.Foreign
24 , queryStr
28 , queryStr
25 , argName
29 , argName
26 , argType
30 , argType
31+ , headerArg
27 -- prisms
32 -- prisms
33+ , _PathSegment
34+ , _ForeignType
28 , _HeaderArg
35 , _HeaderArg
29 , _ReplaceHeaderArg
36 , _ReplaceHeaderArg
30 , _Static
37 , _Static
@@ -40,14 +47,13 @@ module Servant.Foreign
40 , NoTypes
47 , NoTypes
41 , captureArg
48 , captureArg
42 , isCapture
49 , isCapture
43− , concatCase
44− , snakeCase
45− , camelCase
46 , defReq
50 , defReq
47 , listFromAPI
51 , listFromAPI
48− -- re-exports
52+ -- re-exports
49 , module Servant.API
53 , module Servant.API
54+ , module Servant.Foreign.Inflections
50 ) where
55 ) where
51
56
52import Servant.API
57import Servant.API
53import Servant.Foreign.Internal
58import Servant.Foreign.Internal
59+import Servant.Foreign.Inflections
servant-foreign/src/Servant/Foreign/Inflections.hsnew file+45
@@ -0,0 +1,45 @@
1+module Servant.Foreign.Inflections
2+ ( concatCase
3+ , snakeCase
4+ , camelCase
5+ -- lenses
6+ , concatCaseL
7+ , snakeCaseL
8+ , camelCaseL
9+ ) where
10+
11+
12+import Control.Lens hiding (cons)
13+import qualified Data.Char as C
14+import Data.Monoid
15+import Data.Text hiding (map)
16+import Prelude hiding (head, tail)
17+import Servant.Foreign.Internal
18+
19+concatCaseL :: Getter FunctionName Text
20+concatCaseL = _FunctionName . to mconcat
21+
22+-- | Function name builder that simply concat each part together
23+concatCase :: FunctionName -> Text
24+concatCase = view concatCaseL
25+
26+snakeCaseL :: Getter FunctionName Text
27+snakeCaseL = _FunctionName . to (intercalate "_")
28+
29+-- | Function name builder using the snake_case convention.
30+-- each part is separated by a single underscore character.
31+snakeCase :: FunctionName -> Text
32+snakeCase = view snakeCaseL
33+
34+camelCaseL :: Getter FunctionName Text
35+camelCaseL = _FunctionName . to (convert . map (replace "-" ""))
36+ where
37+ convert [] = ""
38+ convert (p:ps) = mconcat $ p : map capitalize ps
39+ capitalize "" = ""
40+ capitalize name = C.toUpper (head name) `cons` tail name
41+
42+-- | Function name builder using the CamelCase convention.
43+-- each part begins with an upper case character.
44+camelCase :: FunctionName -> Text
45+camelCase = view camelCaseL
servant-foreign/src/Servant/Foreign/Internal.hs+67−65
@@ -1,27 +1,18 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6#if !MIN_VERSION_base(4,8,0)
2#if !MIN_VERSION_base(4,8,0)
7−{-# LANGUAGE NullaryTypeClasses #-}
3+{-# LANGUAGE NullaryTypeClasses #-}
8#endif
4#endif
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TemplateHaskell #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−{-# LANGUAGE OverloadedStrings #-}
16−{-# LANGUAGE PolyKinds #-}
17
5
18-- | Generalizes all the data needed to make code generation work with
6-- | Generalizes all the data needed to make code generation work with
19-- arbitrary programming languages.
7-- arbitrary programming languages.
20module Servant.Foreign.Internal where
8module Servant.Foreign.Internal where
21
9
22−import Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~))
10+import Control.Lens hiding (cons, List)
11+#if !MIN_VERSION_base(4,8,0)
23−import qualified Data.Char as C
12+import Data.Monoid
13+#endif
24import Data.Proxy
14import Data.Proxy
15+import Data.String
25import Data.Text
16import Data.Text
26import Data.Text.Encoding (decodeUtf8)
17import Data.Text.Encoding (decodeUtf8)
27import GHC.Exts (Constraint)
18import GHC.Exts (Constraint)
@@ -30,36 +21,38 @@ import qualified Network.HTTP.Types as HTTP
30import Prelude hiding (concat)
21import Prelude hiding (concat)
31import Servant.API
22import Servant.API
32
23
33−type FunctionName = [Text]
34
24
35−-- | Function name builder that simply concat each part together
25+newtype FunctionName = FunctionName { unFunctionName :: [Text] }
26+ deriving (Show, Eq, Monoid)
27+
36−concatCase :: FunctionName -> Text
28+makePrisms ''FunctionName
37−concatCase = concat
29+
30+newtype ForeignType = ForeignType { unForeignType :: Text }
31+ deriving (Show, Eq, IsString, Monoid)
38
32
39−-- | Function name builder using the snake_case convention.
33+makePrisms ''ForeignType
40−-- each part is separated by a single underscore character.
41−snakeCase :: FunctionName -> Text
42−snakeCase = intercalate "_"
43
34
44−-- | Function name builder using the CamelCase convention.
35+newtype PathSegment = PathSegment { unPathSegment :: Text }
45−-- each part begins with an upper case character.
36+ deriving (Show, Eq, IsString, Monoid)
46−camelCase :: FunctionName -> Text
47−camelCase = camelCase' . Prelude.map (replace "-" "")
48− where camelCase' [] = ""
49− camelCase' (p:ps) = concat $ p : Prelude.map capitalize ps
50− capitalize "" = ""
51− capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name
52
37
53−type ForeignType = Text
38+makePrisms ''PathSegment
54
39
55−type Arg = (Text, ForeignType)
40+data Arg = Arg
41+ { _aName :: PathSegment
42+ , _aType :: ForeignType }
43+ deriving (Show, Eq)
44+
45+makeLenses ''Arg
46+
47+aPath :: Getter Arg Text
48+aPath = aName . _PathSegment
56
49
57data SegmentType
50data SegmentType
58− = Static Text
51+ = Static PathSegment
59 -- ^ a static path segment. like "/foo"
52 -- ^ a static path segment. like "/foo"
60 | Cap Arg
53 | Cap Arg
61 -- ^ a capture. like "/:userid"
54 -- ^ a capture. like "/:userid"
62− deriving (Eq, Show)
55+ deriving (Show, Eq)
63
56
64makePrisms ''SegmentType
57makePrisms ''SegmentType
65
58
@@ -68,6 +61,14 @@ newtype Segment = Segment { unSegment :: SegmentType }
68
61
69makePrisms ''Segment
62makePrisms ''Segment
70
63
64+isCapture :: Segment -> Bool
65+isCapture (Segment (Cap _)) = True
66+isCapture _ = False
67+
68+captureArg :: Segment -> Arg
69+captureArg (Segment (Cap s)) = s
70+captureArg _ = error "captureArg called on non capture"
71+
71type Path = [Segment]
72type Path = [Segment]
72
73
73data ArgType
74data ArgType
@@ -86,10 +87,10 @@ data QueryArg = QueryArg
86makeLenses ''QueryArg
87makeLenses ''QueryArg
87
88
88data HeaderArg = HeaderArg
89data HeaderArg = HeaderArg
89− { headerArg :: Arg }
90+ { _headerArg :: Arg }
90 | ReplaceHeaderArg
91 | ReplaceHeaderArg
91− { headerArg :: Arg
92+ { _headerArg :: Arg
92− , headerPattern :: Text
93+ , _headerPattern :: Text
93 } deriving (Eq, Show)
94 } deriving (Eq, Show)
94
95
95makeLenses ''HeaderArg
96makeLenses ''HeaderArg
@@ -117,16 +118,8 @@ data Req = Req
117
118
118makeLenses ''Req
119makeLenses ''Req
119
120
120−isCapture :: Segment -> Bool
121−isCapture (Segment (Cap _)) = True
122−isCapture _ = False
123−
124−captureArg :: Segment -> Arg
125−captureArg (Segment (Cap s)) = s
126−captureArg _ = error "captureArg called on non capture"
127−
128defReq :: Req
121defReq :: Req
129−defReq = Req defUrl "GET" [] Nothing "" []
122+defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName [])
130
123
131-- | To be used exclusively as a "negative" return type/constraint
124-- | To be used exclusively as a "negative" return type/constraint
132-- by @'Elem`@ type family.
125-- by @'Elem`@ type family.
@@ -173,7 +166,7 @@ class HasForeignType lang a where
173data NoTypes
166data NoTypes
174
167
175instance HasForeignType NoTypes ftype where
168instance HasForeignType NoTypes ftype where
176− typeFor _ _ = empty
169+ typeFor _ _ = ForeignType empty
177
170
178type HasNoForeignType = HasForeignType NoTypes
171type HasNoForeignType = HasForeignType NoTypes
179
172
@@ -195,18 +188,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout)
195
188
196 foreignFor lang Proxy req =
189 foreignFor lang Proxy req =
197 foreignFor lang (Proxy :: Proxy sublayout) $
190 foreignFor lang (Proxy :: Proxy sublayout) $
198− req & reqUrl.path <>~ [Segment (Cap arg)]
191+ req & reqUrl . path <>~ [Segment (Cap arg)]
199− & reqFuncName %~ (++ ["by", str])
192+ & reqFuncName . _FunctionName %~ (++ ["by", str])
200 where
193 where
201− str = pack . symbolVal $ (Proxy :: Proxy sym)
194+ str = pack . symbolVal $ (Proxy :: Proxy sym)
202− arg = (str, typeFor lang (Proxy :: Proxy ftype))
195+ ftype = typeFor lang (Proxy :: Proxy ftype)
196+ arg = Arg
197+ { _aName = PathSegment str
198+ , _aType = ftype }
203
199
204instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
200instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
205 => HasForeign lang (Verb method status list a) where
201 => HasForeign lang (Verb method status list a) where
206 type Foreign (Verb method status list a) = Req
202 type Foreign (Verb method status list a) = Req
207
203
208 foreignFor lang Proxy req =
204 foreignFor lang Proxy req =
209− req & reqFuncName %~ (methodLC :)
205+ req & reqFuncName . _FunctionName %~ (methodLC :)
210 & reqMethod .~ method
206 & reqMethod .~ method
211 & reqReturnType .~ retType
207 & reqReturnType .~ retType
212 where
208 where
@@ -219,12 +215,13 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
219 type Foreign (Header sym a :> sublayout) = Foreign sublayout
215 type Foreign (Header sym a :> sublayout) = Foreign sublayout
220
216
221 foreignFor lang Proxy req =
217 foreignFor lang Proxy req =
222− foreignFor lang subP $ req
223− & reqHeaders <>~ [HeaderArg arg]
218+ foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg]
224 where
219 where
225 hname = pack . symbolVal $ (Proxy :: Proxy sym)
220 hname = pack . symbolVal $ (Proxy :: Proxy sym)
221+ arg = Arg
222+ { _aName = PathSegment hname
226− arg = (hname, typeFor lang (Proxy :: Proxy a))
223+ , _aType = typeFor lang (Proxy :: Proxy a) }
227− subP = Proxy :: Proxy sublayout
224+ subP = Proxy :: Proxy sublayout
228
225
229instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
226instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
230 => HasForeign lang (QueryParam sym a :> sublayout) where
227 => HasForeign lang (QueryParam sym a :> sublayout) where
@@ -233,10 +230,11 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
233 foreignFor lang Proxy req =
230 foreignFor lang Proxy req =
234 foreignFor lang (Proxy :: Proxy sublayout) $
231 foreignFor lang (Proxy :: Proxy sublayout) $
235 req & reqUrl.queryStr <>~ [QueryArg arg Normal]
232 req & reqUrl.queryStr <>~ [QueryArg arg Normal]
236−
237 where
233 where
238 str = pack . symbolVal $ (Proxy :: Proxy sym)
234 str = pack . symbolVal $ (Proxy :: Proxy sym)
235+ arg = Arg
236+ { _aName = PathSegment str
239− arg = (str, typeFor lang (Proxy :: Proxy a))
237+ , _aType = typeFor lang (Proxy :: Proxy a) }
240
238
241instance
239instance
242 (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
240 (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
@@ -247,7 +245,9 @@ instance
247 req & reqUrl.queryStr <>~ [QueryArg arg List]
245 req & reqUrl.queryStr <>~ [QueryArg arg List]
248 where
246 where
249 str = pack . symbolVal $ (Proxy :: Proxy sym)
247 str = pack . symbolVal $ (Proxy :: Proxy sym)
248+ arg = Arg
249+ { _aName = PathSegment str
250− arg = (str, typeFor lang (Proxy :: Proxy [a]))
250+ , _aType = typeFor lang (Proxy :: Proxy [a]) }
251
251
252instance
252instance
253 (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout)
253 (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout)
@@ -259,13 +259,15 @@ instance
259 req & reqUrl.queryStr <>~ [QueryArg arg Flag]
259 req & reqUrl.queryStr <>~ [QueryArg arg Flag]
260 where
260 where
261 str = pack . symbolVal $ (Proxy :: Proxy sym)
261 str = pack . symbolVal $ (Proxy :: Proxy sym)
262+ arg = Arg
263+ { _aName = PathSegment str
262− arg = (str, typeFor lang (Proxy :: Proxy Bool))
264+ , _aType = typeFor lang (Proxy :: Proxy Bool) }
263
265
264instance HasForeign lang Raw where
266instance HasForeign lang Raw where
265 type Foreign Raw = HTTP.Method -> Req
267 type Foreign Raw = HTTP.Method -> Req
266
268
267 foreignFor _ Proxy req method =
269 foreignFor _ Proxy req method =
268− req & reqFuncName %~ ((toLower $ decodeUtf8 method) :)
270+ req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
269 & reqMethod .~ method
271 & reqMethod .~ method
270
272
271instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)
273instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)
@@ -282,8 +284,8 @@ instance (KnownSymbol path, HasForeign lang sublayout)
282
284
283 foreignFor lang Proxy req =
285 foreignFor lang Proxy req =
284 foreignFor lang (Proxy :: Proxy sublayout) $
286 foreignFor lang (Proxy :: Proxy sublayout) $
285− req & reqUrl.path <>~ [Segment (Static str)]
287+ req & reqUrl . path <>~ [Segment (Static (PathSegment str))]
286− & reqFuncName %~ (++ [str])
288+ & reqFuncName . _FunctionName %~ (++ [str])
287 where
289 where
288 str =
290 str =
289 Data.Text.map (\c -> if c == '.' then '_' else c)
291 Data.Text.map (\c -> if c == '.' then '_' else c)
servant-foreign/test/Servant/ForeignSpec.hs+15−22
@@ -1,13 +1,4 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE TypeSynonymInstances #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE CPP #-}
10−
11#include "overlapping-compat.h"
2#include "overlapping-compat.h"
12
3
13module Servant.ForeignSpec where
4module Servant.ForeignSpec where
@@ -26,15 +17,17 @@ spec = describe "Servant.Foreign" $ do
26camelCaseSpec :: Spec
17camelCaseSpec :: Spec
27camelCaseSpec = describe "camelCase" $ do
18camelCaseSpec = describe "camelCase" $ do
28 it "converts FunctionNames to camelCase" $ do
19 it "converts FunctionNames to camelCase" $ do
20+ camelCase (FunctionName ["post", "counter", "inc"])
29− camelCase ["post", "counter", "inc"] `shouldBe` "postCounterInc"
21+ `shouldBe` "postCounterInc"
22+ camelCase (FunctionName ["get", "hyphen-ated", "counter"])
30− camelCase ["get", "hyphen-ated", "counter"] `shouldBe` "getHyphenatedCounter"
23+ `shouldBe` "getHyphenatedCounter"
31
24
32----------------------------------------------------------------------
25----------------------------------------------------------------------
33
26
34data LangX
27data LangX
35
28
36instance HasForeignType LangX () where
29instance HasForeignType LangX () where
37− typeFor _ _ = "voidX"
30+ typeFor _ _ = ForeignType "voidX"
38
31
39instance HasForeignType LangX Int where
32instance HasForeignType LangX Int where
40 typeFor _ _ = "intX"
33 typeFor _ _ = "intX"
@@ -68,24 +61,24 @@ listFromAPISpec = describe "listFromAPI" $ do
68 shouldBe getReq $ defReq
61 shouldBe getReq $ defReq
69 { _reqUrl = Url
62 { _reqUrl = Url
70 [ Segment $ Static "test" ]
63 [ Segment $ Static "test" ]
71− [ QueryArg ("flag", "boolX") Flag ]
64+ [ QueryArg (Arg "flag" "boolX") Flag ]
72 , _reqMethod = "GET"
65 , _reqMethod = "GET"
73− , _reqHeaders = [HeaderArg ("header", "listX of stringX")]
66+ , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"]
74 , _reqBody = Nothing
67 , _reqBody = Nothing
75 , _reqReturnType = "intX"
68 , _reqReturnType = "intX"
76− , _reqFuncName = ["get", "test"]
69+ , _reqFuncName = FunctionName ["get", "test"]
77 }
70 }
78
71
79 it "collects all info for post request" $ do
72 it "collects all info for post request" $ do
80 shouldBe postReq $ defReq
73 shouldBe postReq $ defReq
81 { _reqUrl = Url
74 { _reqUrl = Url
82 [ Segment $ Static "test" ]
75 [ Segment $ Static "test" ]
83− [ QueryArg ("param", "intX") Normal ]
76+ [ QueryArg (Arg "param" "intX") Normal ]
84 , _reqMethod = "POST"
77 , _reqMethod = "POST"
85 , _reqHeaders = []
78 , _reqHeaders = []
86 , _reqBody = Just "listX of stringX"
79 , _reqBody = Just "listX of stringX"
87 , _reqReturnType = "voidX"
80 , _reqReturnType = "voidX"
88− , _reqFuncName = ["post", "test"]
81+ , _reqFuncName = FunctionName ["post", "test"]
89 }
82 }
90
83
91 it "collects all info for put request" $ do
84 it "collects all info for put request" $ do
@@ -93,23 +86,23 @@ listFromAPISpec = describe "listFromAPI" $ do
93 { _reqUrl = Url
86 { _reqUrl = Url
94 [ Segment $ Static "test" ]
87 [ Segment $ Static "test" ]
95 -- Shoud this be |intX| or |listX of intX| ?
88 -- Shoud this be |intX| or |listX of intX| ?
96− [ QueryArg ("params", "listX of intX") List ]
89+ [ QueryArg (Arg "params" "listX of intX") List ]
97 , _reqMethod = "PUT"
90 , _reqMethod = "PUT"
98 , _reqHeaders = []
91 , _reqHeaders = []
99 , _reqBody = Just "stringX"
92 , _reqBody = Just "stringX"
100 , _reqReturnType = "voidX"
93 , _reqReturnType = "voidX"
101− , _reqFuncName = ["put", "test"]
94+ , _reqFuncName = FunctionName ["put", "test"]
102 }
95 }
103
96
104 it "collects all info for delete request" $ do
97 it "collects all info for delete request" $ do
105 shouldBe deleteReq $ defReq
98 shouldBe deleteReq $ defReq
106 { _reqUrl = Url
99 { _reqUrl = Url
107 [ Segment $ Static "test"
100 [ Segment $ Static "test"
108− , Segment $ Cap ("id", "intX") ]
101+ , Segment $ Cap (Arg "id" "intX") ]
109 []
102 []
110 , _reqMethod = "DELETE"
103 , _reqMethod = "DELETE"
111 , _reqHeaders = []
104 , _reqHeaders = []
112 , _reqBody = Nothing
105 , _reqBody = Nothing
113 , _reqReturnType = "voidX"
106 , _reqReturnType = "voidX"
114− , _reqFuncName = ["delete", "test", "by", "id"]
107+ , _reqFuncName = FunctionName ["delete", "test", "by", "id"]
115 }
108 }
servant-js/src/Servant/JS/Angular.hs+12−8
@@ -76,9 +76,12 @@ generateAngularJSWith ngOptions opts req = "\n" <>
76 where argsStr = T.intercalate ", " args
76 where argsStr = T.intercalate ", " args
77 args = http
77 args = http
78 ++ captures
78 ++ captures
79− ++ map (view $ argName._1) queryparams
79+ ++ map (view $ argName . aPath) queryparams
80 ++ body
80 ++ body
81− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs
81+ ++ map ( toValidFunctionName
82+ . (<>) "header"
83+ . view (headerArg . aPath)
84+ ) hs
82
85
83 -- If we want to generate Top Level Function, they must depend on
86 -- If we want to generate Top Level Function, they must depend on
84 -- the $http service, if we generate a service, the functions will
87 -- the $http service, if we generate a service, the functions will
@@ -87,9 +90,9 @@ generateAngularJSWith ngOptions opts req = "\n" <>
87 0 -> ["$http"]
90 0 -> ["$http"]
88 _ -> []
91 _ -> []
89
92
90− captures = map (fst . captureArg)
93+ captures = map (view aPath . captureArg)
91 . filter isCapture
94 . filter isCapture
92− $ req ^. reqUrl.path
95+ $ req ^. reqUrl . path
93
96
94 hs = req ^. reqHeaders
97 hs = req ^. reqHeaders
95
98
@@ -110,10 +113,11 @@ generateAngularJSWith ngOptions opts req = "\n" <>
110 then ""
113 then ""
111 else " , headers: { " <> headersStr <> " }\n"
114 else " , headers: { " <> headersStr <> " }\n"
112
115
116+ where
113− where headersStr = T.intercalate ", " $ map headerStr hs
117+ headersStr = T.intercalate ", " $ map headerStr hs
114− headerStr header = "\"" <>
118+ headerStr header = "\"" <>
115− fst (headerArg header) <>
119+ header ^. headerArg . aPath <>
116− "\": " <> toJSHeader header
120+ "\": " <> toJSHeader header
117
121
118 namespace =
122 namespace =
119 if hasService
123 if hasService
servant-js/src/Servant/JS/Axios.hs+11−7
@@ -62,11 +62,14 @@ generateAxiosJSWith aopts opts req = "\n" <>
62
62
63 where argsStr = T.intercalate ", " args
63 where argsStr = T.intercalate ", " args
64 args = captures
64 args = captures
65− ++ map (view $ argName._1) queryparams
65+ ++ map (view $ argName . aPath) queryparams
66 ++ body
66 ++ body
67− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs
67+ ++ map ( toValidFunctionName
68+ . (<>) "header"
69+ . view (headerArg . aPath)
70+ ) hs
68
71
69− captures = map (fst . captureArg)
72+ captures = map (view aPath . captureArg)
70 . filter isCapture
73 . filter isCapture
71 $ req ^. reqUrl.path
74 $ req ^. reqUrl.path
72
75
@@ -104,10 +107,11 @@ generateAxiosJSWith aopts opts req = "\n" <>
104 then ""
107 then ""
105 else " , headers: { " <> headersStr <> " }\n"
108 else " , headers: { " <> headersStr <> " }\n"
106
109
110+ where
107− where headersStr = T.intercalate ", " $ map headerStr hs
111+ headersStr = T.intercalate ", " $ map headerStr hs
108− headerStr header = "\"" <>
112+ headerStr header = "\"" <>
109− fst (headerArg header) <>
113+ header ^. headerArg . aPath <>
110− "\": " <> toJSHeader header
114+ "\": " <> toJSHeader header
111
115
112 namespace =
116 namespace =
113 if hasNoModule
117 if hasNoModule
servant-js/src/Servant/JS/Internal.hs+27−8
@@ -1,4 +1,6 @@
1−{-#LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ViewPatterns #-}
3+
2module Servant.JS.Internal
4module Servant.JS.Internal
3 ( JavaScriptGenerator
5 ( JavaScriptGenerator
4 , CommonGeneratorOptions(..)
6 , CommonGeneratorOptions(..)
@@ -19,7 +21,22 @@ module Servant.JS.Internal
19 , reqHeaders
21 , reqHeaders
20 , HasForeign(..)
22 , HasForeign(..)
21 , HasForeignType(..)
23 , HasForeignType(..)
24+ , HasNoForeignType
25+ , GenerateList(..)
26+ , NoTypes
27+ , HeaderArg
28+ , ArgType(..)
22 , HeaderArg(..)
29 , HeaderArg(..)
30+ , QueryArg(..)
31+ , Req(..)
32+ , Segment(..)
33+ , SegmentType(..)
34+ , Url(..)
35+ , Path
36+ , ForeignType(..)
37+ , Arg(..)
38+ , FunctionName(..)
39+ , PathSegment(..)
23 , concatCase
40 , concatCase
24 , snakeCase
41 , snakeCase
25 , camelCase
42 , camelCase
@@ -32,7 +49,7 @@ module Servant.JS.Internal
32 , Header
49 , Header
33 ) where
50 ) where
34
51
35−import Control.Lens ((^.), _1)
52+import Control.Lens hiding (List)
36import qualified Data.CharSet as Set
53import qualified Data.CharSet as Set
37import qualified Data.CharSet.Unicode.Category as Set
54import qualified Data.CharSet.Unicode.Category as Set
38import Data.Monoid
55import Data.Monoid
@@ -123,7 +140,8 @@ toValidFunctionName t =
123 ]
140 ]
124
141
125toJSHeader :: HeaderArg -> Text
142toJSHeader :: HeaderArg -> Text
126−toJSHeader (HeaderArg n) = toValidFunctionName ("header" <> fst n)
143+toJSHeader (HeaderArg n)
144+ = toValidFunctionName ("header" <> n ^. aName . _PathSegment)
127toJSHeader (ReplaceHeaderArg n p)
145toJSHeader (ReplaceHeaderArg n p)
128 | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\""
146 | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\""
129 | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv
147 | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv
@@ -131,8 +149,8 @@ toJSHeader (ReplaceHeaderArg n p)
131 <> "\""
149 <> "\""
132 | otherwise = p
150 | otherwise = p
133 where
151 where
134− pv = toValidFunctionName ("header" <> fst n)
152+ pv = toValidFunctionName ("header" <> n ^. aName . _PathSegment)
135− pn = "{" <> fst n <> "}"
153+ pn = "{" <> n ^. aName . _PathSegment <> "}"
136 rp = T.replace pn "" p
154 rp = T.replace pn "" p
137
155
138jsSegments :: [Segment] -> Text
156jsSegments :: [Segment] -> Text
@@ -145,8 +163,9 @@ segmentToStr (Segment st) notTheEnd =
145 segmentTypeToStr st <> if notTheEnd then "" else "'"
163 segmentTypeToStr st <> if notTheEnd then "" else "'"
146
164
147segmentTypeToStr :: SegmentType -> Text
165segmentTypeToStr :: SegmentType -> Text
148−segmentTypeToStr (Static s) = s
166+segmentTypeToStr (Static s) = s ^. _PathSegment
149−segmentTypeToStr (Cap s) = "' + encodeURIComponent(" <> fst s <> ") + '"
167+segmentTypeToStr (Cap s) =
168+ "' + encodeURIComponent(" <> s ^. aName . _PathSegment <> ") + '"
150
169
151jsGParams :: Text -> [QueryArg] -> Text
170jsGParams :: Text -> [QueryArg] -> Text
152jsGParams _ [] = ""
171jsGParams _ [] = ""
@@ -168,4 +187,4 @@ paramToStr qarg notTheEnd =
168 <> "[]=' + encodeURIComponent("
187 <> "[]=' + encodeURIComponent("
169 <> name
188 <> name
170 <> if notTheEnd then ") + '" else ")"
189 <> if notTheEnd then ") + '" else ")"
171− where name = qarg ^. argName . _1
190+ where name = qarg ^. argName . aName . _PathSegment
servant-js/src/Servant/JS/JQuery.hs+12−7
@@ -10,6 +10,7 @@ import Data.Text.Encoding (decodeUtf8)
10import Servant.Foreign
10import Servant.Foreign
11import Servant.JS.Internal
11import Servant.JS.Internal
12
12
13+
13-- | Generate javascript functions that use the /jQuery/ library
14-- | Generate javascript functions that use the /jQuery/ library
14-- to make the AJAX calls. Uses 'defCommonGeneratorOptions'
15-- to make the AJAX calls. Uses 'defCommonGeneratorOptions'
15-- for the generator options.
16-- for the generator options.
@@ -42,12 +43,15 @@ generateJQueryJSWith opts req = "\n" <>
42
43
43 where argsStr = T.intercalate ", " args
44 where argsStr = T.intercalate ", " args
44 args = captures
45 args = captures
45− ++ map (view $ argName._1) queryparams
46+ ++ map (view $ argName . aPath) queryparams
46 ++ body
47 ++ body
47− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs
48+ ++ map (toValidFunctionName
49+ . (<>) "header"
50+ . view (headerArg . aPath)
51+ ) hs
48 ++ [onSuccess, onError]
52 ++ [onSuccess, onError]
49
53
50− captures = map (fst . captureArg)
54+ captures = map (view aPath . captureArg)
51 . filter isCapture
55 . filter isCapture
52 $ req ^. reqUrl.path
56 $ req ^. reqUrl.path
53
57
@@ -73,10 +77,11 @@ generateJQueryJSWith opts req = "\n" <>
73 then ""
77 then ""
74 else " , headers: { " <> headersStr <> " }\n"
78 else " , headers: { " <> headersStr <> " }\n"
75
79
80+ where
76− where headersStr = T.intercalate ", " $ map headerStr hs
81+ headersStr = T.intercalate ", " $ map headerStr hs
77− headerStr header = "\"" <>
82+ headerStr header = "\"" <>
78− fst (headerArg header) <>
83+ header ^. headerArg . aPath <>
79− "\": " <> toJSHeader header
84+ "\": " <> toJSHeader header
80
85
81 namespace = if (moduleName opts) == ""
86 namespace = if (moduleName opts) == ""
82 then "var "
87 then "var "
servant-js/src/Servant/JS/Vanilla.hs+11−7
@@ -54,12 +54,15 @@ generateVanillaJSWith opts req = "\n" <>
54
54
55 where argsStr = T.intercalate ", " args
55 where argsStr = T.intercalate ", " args
56 args = captures
56 args = captures
57− ++ map (view $ argName._1) queryparams
57+ ++ map (view $ argName . aPath) queryparams
58 ++ body
58 ++ body
59− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs
59+ ++ map ( toValidFunctionName
60+ . (<>) "header"
61+ . view (headerArg . aPath)
62+ ) hs
60 ++ [onSuccess, onError]
63 ++ [onSuccess, onError]
61
64
62− captures = map (fst . captureArg)
65+ captures = map (view aPath . captureArg)
63 . filter isCapture
66 . filter isCapture
64 $ req ^. reqUrl.path
67 $ req ^. reqUrl.path
65
68
@@ -85,10 +88,11 @@ generateVanillaJSWith opts req = "\n" <>
85 then ""
88 then ""
86 else headersStr <> "\n"
89 else headersStr <> "\n"
87
90
91+ where
88− where headersStr = T.intercalate "\n" $ map headerStr hs
92+ headersStr = T.intercalate "\n" $ map headerStr hs
89− headerStr header = " xhr.setRequestHeader(\"" <>
93+ headerStr header = " xhr.setRequestHeader(\"" <>
90− fst (headerArg header) <>
94+ header ^. headerArg . aPath <>
91− "\", " <> toJSHeader header <> ");"
95+ "\", " <> toJSHeader header <> ");"
92
96
93 namespace = if moduleName opts == ""
97 namespace = if moduleName opts == ""
94 then "var "
98 then "var "
servant-js/test/Servant/JSSpec/CustomHeaders.hs+5−4
@@ -27,8 +27,9 @@ instance (KnownSymbol sym, HasForeign lang sublayout)
27 type Foreign (Authorization sym a :> sublayout) = Foreign sublayout
27 type Foreign (Authorization sym a :> sublayout) = Foreign sublayout
28
28
29 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $
29 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $
30+ req & reqHeaders <>~
30− req & reqHeaders <>~ [ ReplaceHeaderArg ("Authorization", "") $
31+ [ ReplaceHeaderArg (Arg "Authorization" "")
31− tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ]
32+ $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ]
32 where
33 where
33 tokenType t = t <> " {Authorization}"
34 tokenType t = t <> " {Authorization}"
34
35
@@ -40,7 +41,7 @@ instance (HasForeign lang sublayout)
40 type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout
41 type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout
41
42
42 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $
43 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $
43− req & reqHeaders <>~ [ ReplaceHeaderArg ("X-MyLovelyHorse", "") tpl ]
44+ req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" "") tpl ]
44 where
45 where
45 tpl = "I am good friends with {X-MyLovelyHorse}"
46 tpl = "I am good friends with {X-MyLovelyHorse}"
46
47
@@ -52,6 +53,6 @@ instance (HasForeign lang sublayout)
52 type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout
53 type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout
53
54
54 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $
55 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $
55− req & reqHeaders <>~ [ ReplaceHeaderArg ("X-WhatsForDinner", "") tpl ]
56+ req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" "") tpl ]
56 where
57 where
57 tpl = "I would like {X-WhatsForDinner} with a cherry on top."
58 tpl = "I would like {X-WhatsForDinner} with a cherry on top."