git.iko.soy/servant
on master help sign in
Merge pull request #378 from haskell-servant/textly-typed

Utilize newtypes in servant-foreign

commite34003e9afc3a1bb8d0e8b056534adbcae9413ac authorDenis Redozubov <denis.redozubov@gmail.com> dateSat 12 Mar 2016, 16:16 (11 years ago) parent16e7234d8e98a1
11 files changed+248−138
compare with master
unifiedsplit
servant-foreign/servant-foreign.cabal+30−3 servant-foreign/src/Servant/Foreign.hs+13−7 servant-foreign/src/Servant/Foreign/Inflections.hs+45 servant-foreign/src/Servant/Foreign/Internal.hs+67−65 servant-foreign/test/Servant/ForeignSpec.hs+15−22 servant-js/src/Servant/JS/Angular.hs+12−8 servant-js/src/Servant/JS/Axios.hs+11−7 servant-js/src/Servant/JS/Internal.hs+27−8 servant-js/src/Servant/JS/JQuery.hs+12−7 servant-js/src/Servant/JS/Vanilla.hs+11−7 servant-js/test/Servant/JSSpec/CustomHeaders.hs+5−4
servant-foreign/servant-foreign.cabal+30−3
@@ -26,7 +26,9 @@ source-repository head
2626 location: http://github.com/haskell-servant/servant.git
2727
2828library
29− exposed-modules: Servant.Foreign, Servant.Foreign.Internal
29+ exposed-modules: Servant.Foreign
30+ , Servant.Foreign.Internal
31+ , Servant.Foreign.Inflections
3032 build-depends: base == 4.*
3133 , lens == 4.*
3234 , servant == 0.5.*
@@ -36,6 +38,20 @@ library
3638 default-language: Haskell2010
3739 ghc-options: -Wall
3840 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
3955
4056
4157test-suite spec
@@ -44,9 +60,20 @@ test-suite spec
4460 ghc-options: -Wall
4561 include-dirs: include
4662 main-is: Spec.hs
47− other-modules:
48− Servant.ForeignSpec
63+ other-modules: Servant.ForeignSpec
4964 build-depends: base
5065 , hspec >= 2.1.8
5166 , servant-foreign
5267 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
1010 , Url(..)
1111 -- aliases
1212 , Path
13− , ForeignType
14− , Arg
15− , FunctionName
13+ , ForeignType(..)
14+ , Arg(..)
15+ , FunctionName(..)
16+ , PathSegment(..)
1617 -- lenses
18+ , aName
19+ , aType
20+ , aPath
1721 , reqUrl
1822 , reqMethod
1923 , reqHeaders
@@ -24,7 +28,10 @@ module Servant.Foreign
2428 , queryStr
2529 , argName
2630 , argType
31+ , headerArg
2732 -- prisms
33+ , _PathSegment
34+ , _ForeignType
2835 , _HeaderArg
2936 , _ReplaceHeaderArg
3037 , _Static
@@ -40,14 +47,13 @@ module Servant.Foreign
4047 , NoTypes
4148 , captureArg
4249 , isCapture
43− , concatCase
44− , snakeCase
45− , camelCase
4650 , defReq
4751 , listFromAPI
48− -- re-exports
52+ -- re-exports
4953 , module Servant.API
54+ , module Servant.Foreign.Inflections
5055 ) where
5156
5257import Servant.API
5358import 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 #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
1+{-# LANGUAGE CPP #-}
62#if !MIN_VERSION_base(4,8,0)
7−{-# LANGUAGE NullaryTypeClasses #-}
3+{-# LANGUAGE NullaryTypeClasses #-}
84#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 #-}
175
186-- | Generalizes all the data needed to make code generation work with
197-- arbitrary programming languages.
208module Servant.Foreign.Internal where
219
22−import Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~))
23−import qualified Data.Char as C
10+import Control.Lens hiding (cons, List)
11+#if !MIN_VERSION_base(4,8,0)
12+import Data.Monoid
13+#endif
2414import Data.Proxy
15+import Data.String
2516import Data.Text
2617import Data.Text.Encoding (decodeUtf8)
2718import GHC.Exts (Constraint)
@@ -30,36 +21,38 @@ import qualified Network.HTTP.Types as HTTP
3021import Prelude hiding (concat)
3122import Servant.API
3223
33−type FunctionName = [Text]
3424
35−-- | Function name builder that simply concat each part together
36−concatCase :: FunctionName -> Text
37−concatCase = concat
25+newtype FunctionName = FunctionName { unFunctionName :: [Text] }
26+ deriving (Show, Eq, Monoid)
27+
28+makePrisms ''FunctionName
29+
30+newtype ForeignType = ForeignType { unForeignType :: Text }
31+ deriving (Show, Eq, IsString, Monoid)
3832
39−-- | Function name builder using the snake_case convention.
40−-- each part is separated by a single underscore character.
41−snakeCase :: FunctionName -> Text
42−snakeCase = intercalate "_"
33+makePrisms ''ForeignType
4334
44−-- | Function name builder using the CamelCase convention.
45−-- each part begins with an upper case character.
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
35+newtype PathSegment = PathSegment { unPathSegment :: Text }
36+ deriving (Show, Eq, IsString, Monoid)
5237
53−type ForeignType = Text
38+makePrisms ''PathSegment
5439
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
5649
5750data SegmentType
58− = Static Text
51+ = Static PathSegment
5952 -- ^ a static path segment. like "/foo"
6053 | Cap Arg
6154 -- ^ a capture. like "/:userid"
62− deriving (Eq, Show)
55+ deriving (Show, Eq)
6356
6457makePrisms ''SegmentType
6558
@@ -68,6 +61,14 @@ newtype Segment = Segment { unSegment :: SegmentType }
6861
6962makePrisms ''Segment
7063
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+
7172type Path = [Segment]
7273
7374data ArgType
@@ -86,10 +87,10 @@ data QueryArg = QueryArg
8687makeLenses ''QueryArg
8788
8889data HeaderArg = HeaderArg
89− { headerArg :: Arg }
90+ { _headerArg :: Arg }
9091 | ReplaceHeaderArg
91− { headerArg :: Arg
92− , headerPattern :: Text
92+ { _headerArg :: Arg
93+ , _headerPattern :: Text
9394 } deriving (Eq, Show)
9495
9596makeLenses ''HeaderArg
@@ -117,16 +118,8 @@ data Req = Req
117118
118119makeLenses ''Req
119120
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−
128121defReq :: Req
129−defReq = Req defUrl "GET" [] Nothing "" []
122+defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName [])
130123
131124-- | To be used exclusively as a "negative" return type/constraint
132125-- by @'Elem`@ type family.
@@ -173,7 +166,7 @@ class HasForeignType lang a where
173166data NoTypes
174167
175168instance HasForeignType NoTypes ftype where
176− typeFor _ _ = empty
169+ typeFor _ _ = ForeignType empty
177170
178171type HasNoForeignType = HasForeignType NoTypes
179172
@@ -195,18 +188,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout)
195188
196189 foreignFor lang Proxy req =
197190 foreignFor lang (Proxy :: Proxy sublayout) $
198− req & reqUrl.path <>~ [Segment (Cap arg)]
199− & reqFuncName %~ (++ ["by", str])
191+ req & reqUrl . path <>~ [Segment (Cap arg)]
192+ & reqFuncName . _FunctionName %~ (++ ["by", str])
200193 where
201− str = pack . symbolVal $ (Proxy :: Proxy sym)
202− arg = (str, typeFor lang (Proxy :: Proxy ftype))
194+ str = pack . symbolVal $ (Proxy :: Proxy sym)
195+ ftype = typeFor lang (Proxy :: Proxy ftype)
196+ arg = Arg
197+ { _aName = PathSegment str
198+ , _aType = ftype }
203199
204200instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
205201 => HasForeign lang (Verb method status list a) where
206202 type Foreign (Verb method status list a) = Req
207203
208204 foreignFor lang Proxy req =
209− req & reqFuncName %~ (methodLC :)
205+ req & reqFuncName . _FunctionName %~ (methodLC :)
210206 & reqMethod .~ method
211207 & reqReturnType .~ retType
212208 where
@@ -219,12 +215,13 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
219215 type Foreign (Header sym a :> sublayout) = Foreign sublayout
220216
221217 foreignFor lang Proxy req =
222− foreignFor lang subP $ req
223− & reqHeaders <>~ [HeaderArg arg]
218+ foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg]
224219 where
225220 hname = pack . symbolVal $ (Proxy :: Proxy sym)
226− arg = (hname, typeFor lang (Proxy :: Proxy a))
227− subP = Proxy :: Proxy sublayout
221+ arg = Arg
222+ { _aName = PathSegment hname
223+ , _aType = typeFor lang (Proxy :: Proxy a) }
224+ subP = Proxy :: Proxy sublayout
228225
229226instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
230227 => HasForeign lang (QueryParam sym a :> sublayout) where
@@ -233,10 +230,11 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
233230 foreignFor lang Proxy req =
234231 foreignFor lang (Proxy :: Proxy sublayout) $
235232 req & reqUrl.queryStr <>~ [QueryArg arg Normal]
236−
237233 where
238234 str = pack . symbolVal $ (Proxy :: Proxy sym)
239− arg = (str, typeFor lang (Proxy :: Proxy a))
235+ arg = Arg
236+ { _aName = PathSegment str
237+ , _aType = typeFor lang (Proxy :: Proxy a) }
240238
241239instance
242240 (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
@@ -247,7 +245,9 @@ instance
247245 req & reqUrl.queryStr <>~ [QueryArg arg List]
248246 where
249247 str = pack . symbolVal $ (Proxy :: Proxy sym)
250− arg = (str, typeFor lang (Proxy :: Proxy [a]))
248+ arg = Arg
249+ { _aName = PathSegment str
250+ , _aType = typeFor lang (Proxy :: Proxy [a]) }
251251
252252instance
253253 (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout)
@@ -259,13 +259,15 @@ instance
259259 req & reqUrl.queryStr <>~ [QueryArg arg Flag]
260260 where
261261 str = pack . symbolVal $ (Proxy :: Proxy sym)
262− arg = (str, typeFor lang (Proxy :: Proxy Bool))
262+ arg = Arg
263+ { _aName = PathSegment str
264+ , _aType = typeFor lang (Proxy :: Proxy Bool) }
263265
264266instance HasForeign lang Raw where
265267 type Foreign Raw = HTTP.Method -> Req
266268
267269 foreignFor _ Proxy req method =
268− req & reqFuncName %~ ((toLower $ decodeUtf8 method) :)
270+ req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
269271 & reqMethod .~ method
270272
271273instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)
@@ -282,8 +284,8 @@ instance (KnownSymbol path, HasForeign lang sublayout)
282284
283285 foreignFor lang Proxy req =
284286 foreignFor lang (Proxy :: Proxy sublayout) $
285− req & reqUrl.path <>~ [Segment (Static str)]
286− & reqFuncName %~ (++ [str])
287+ req & reqUrl . path <>~ [Segment (Static (PathSegment str))]
288+ & reqFuncName . _FunctionName %~ (++ [str])
287289 where
288290 str =
289291 Data.Text.map (\c -> if c == '.' then '_' else c)
servant-foreign/test/Servant/ForeignSpec.hs+15−22
@@ -1,13 +1,4 @@
1−{-# LANGUAGE OverloadedStrings #-}
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−
1+{-# LANGUAGE CPP #-}
112#include "overlapping-compat.h"
123
134module Servant.ForeignSpec where
@@ -26,15 +17,17 @@ spec = describe "Servant.Foreign" $ do
2617camelCaseSpec :: Spec
2718camelCaseSpec = describe "camelCase" $ do
2819 it "converts FunctionNames to camelCase" $ do
29− camelCase ["post", "counter", "inc"] `shouldBe` "postCounterInc"
30− camelCase ["get", "hyphen-ated", "counter"] `shouldBe` "getHyphenatedCounter"
20+ camelCase (FunctionName ["post", "counter", "inc"])
21+ `shouldBe` "postCounterInc"
22+ camelCase (FunctionName ["get", "hyphen-ated", "counter"])
23+ `shouldBe` "getHyphenatedCounter"
3124
3225----------------------------------------------------------------------
3326
3427data LangX
3528
3629instance HasForeignType LangX () where
37− typeFor _ _ = "voidX"
30+ typeFor _ _ = ForeignType "voidX"
3831
3932instance HasForeignType LangX Int where
4033 typeFor _ _ = "intX"
@@ -68,24 +61,24 @@ listFromAPISpec = describe "listFromAPI" $ do
6861 shouldBe getReq $ defReq
6962 { _reqUrl = Url
7063 [ Segment $ Static "test" ]
71− [ QueryArg ("flag", "boolX") Flag ]
64+ [ QueryArg (Arg "flag" "boolX") Flag ]
7265 , _reqMethod = "GET"
73− , _reqHeaders = [HeaderArg ("header", "listX of stringX")]
66+ , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"]
7467 , _reqBody = Nothing
7568 , _reqReturnType = "intX"
76− , _reqFuncName = ["get", "test"]
69+ , _reqFuncName = FunctionName ["get", "test"]
7770 }
7871
7972 it "collects all info for post request" $ do
8073 shouldBe postReq $ defReq
8174 { _reqUrl = Url
8275 [ Segment $ Static "test" ]
83− [ QueryArg ("param", "intX") Normal ]
76+ [ QueryArg (Arg "param" "intX") Normal ]
8477 , _reqMethod = "POST"
8578 , _reqHeaders = []
8679 , _reqBody = Just "listX of stringX"
8780 , _reqReturnType = "voidX"
88− , _reqFuncName = ["post", "test"]
81+ , _reqFuncName = FunctionName ["post", "test"]
8982 }
9083
9184 it "collects all info for put request" $ do
@@ -93,23 +86,23 @@ listFromAPISpec = describe "listFromAPI" $ do
9386 { _reqUrl = Url
9487 [ Segment $ Static "test" ]
9588 -- Shoud this be |intX| or |listX of intX| ?
96− [ QueryArg ("params", "listX of intX") List ]
89+ [ QueryArg (Arg "params" "listX of intX") List ]
9790 , _reqMethod = "PUT"
9891 , _reqHeaders = []
9992 , _reqBody = Just "stringX"
10093 , _reqReturnType = "voidX"
101− , _reqFuncName = ["put", "test"]
94+ , _reqFuncName = FunctionName ["put", "test"]
10295 }
10396
10497 it "collects all info for delete request" $ do
10598 shouldBe deleteReq $ defReq
10699 { _reqUrl = Url
107100 [ Segment $ Static "test"
108− , Segment $ Cap ("id", "intX") ]
101+ , Segment $ Cap (Arg "id" "intX") ]
109102 []
110103 , _reqMethod = "DELETE"
111104 , _reqHeaders = []
112105 , _reqBody = Nothing
113106 , _reqReturnType = "voidX"
114− , _reqFuncName = ["delete", "test", "by", "id"]
107+ , _reqFuncName = FunctionName ["delete", "test", "by", "id"]
115108 }
servant-js/src/Servant/JS/Angular.hs+12−8
@@ -76,9 +76,12 @@ generateAngularJSWith ngOptions opts req = "\n" <>
7676 where argsStr = T.intercalate ", " args
7777 args = http
7878 ++ captures
79− ++ map (view $ argName._1) queryparams
79+ ++ map (view $ argName . aPath) queryparams
8080 ++ body
81− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs
81+ ++ map ( toValidFunctionName
82+ . (<>) "header"
83+ . view (headerArg . aPath)
84+ ) hs
8285
8386 -- If we want to generate Top Level Function, they must depend on
8487 -- the $http service, if we generate a service, the functions will
@@ -87,9 +90,9 @@ generateAngularJSWith ngOptions opts req = "\n" <>
8790 0 -> ["$http"]
8891 _ -> []
8992
90− captures = map (fst . captureArg)
93+ captures = map (view aPath . captureArg)
9194 . filter isCapture
92− $ req ^. reqUrl.path
95+ $ req ^. reqUrl . path
9396
9497 hs = req ^. reqHeaders
9598
@@ -110,10 +113,11 @@ generateAngularJSWith ngOptions opts req = "\n" <>
110113 then ""
111114 else " , headers: { " <> headersStr <> " }\n"
112115
113− where headersStr = T.intercalate ", " $ map headerStr hs
114− headerStr header = "\"" <>
115− fst (headerArg header) <>
116− "\": " <> toJSHeader header
116+ where
117+ headersStr = T.intercalate ", " $ map headerStr hs
118+ headerStr header = "\"" <>
119+ header ^. headerArg . aPath <>
120+ "\": " <> toJSHeader header
117121
118122 namespace =
119123 if hasService
servant-js/src/Servant/JS/Axios.hs+11−7
@@ -62,11 +62,14 @@ generateAxiosJSWith aopts opts req = "\n" <>
6262
6363 where argsStr = T.intercalate ", " args
6464 args = captures
65− ++ map (view $ argName._1) queryparams
65+ ++ map (view $ argName . aPath) queryparams
6666 ++ body
67− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs
67+ ++ map ( toValidFunctionName
68+ . (<>) "header"
69+ . view (headerArg . aPath)
70+ ) hs
6871
69− captures = map (fst . captureArg)
72+ captures = map (view aPath . captureArg)
7073 . filter isCapture
7174 $ req ^. reqUrl.path
7275
@@ -104,10 +107,11 @@ generateAxiosJSWith aopts opts req = "\n" <>
104107 then ""
105108 else " , headers: { " <> headersStr <> " }\n"
106109
107− where headersStr = T.intercalate ", " $ map headerStr hs
108− headerStr header = "\"" <>
109− fst (headerArg header) <>
110− "\": " <> toJSHeader header
110+ where
111+ headersStr = T.intercalate ", " $ map headerStr hs
112+ headerStr header = "\"" <>
113+ header ^. headerArg . aPath <>
114+ "\": " <> toJSHeader header
111115
112116 namespace =
113117 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+
24module Servant.JS.Internal
35 ( JavaScriptGenerator
46 , CommonGeneratorOptions(..)
@@ -19,7 +21,22 @@ module Servant.JS.Internal
1921 , reqHeaders
2022 , HasForeign(..)
2123 , HasForeignType(..)
24+ , HasNoForeignType
25+ , GenerateList(..)
26+ , NoTypes
27+ , HeaderArg
28+ , ArgType(..)
2229 , HeaderArg(..)
30+ , QueryArg(..)
31+ , Req(..)
32+ , Segment(..)
33+ , SegmentType(..)
34+ , Url(..)
35+ , Path
36+ , ForeignType(..)
37+ , Arg(..)
38+ , FunctionName(..)
39+ , PathSegment(..)
2340 , concatCase
2441 , snakeCase
2542 , camelCase
@@ -32,7 +49,7 @@ module Servant.JS.Internal
3249 , Header
3350 ) where
3451
35−import Control.Lens ((^.), _1)
52+import Control.Lens hiding (List)
3653import qualified Data.CharSet as Set
3754import qualified Data.CharSet.Unicode.Category as Set
3855import Data.Monoid
@@ -123,7 +140,8 @@ toValidFunctionName t =
123140 ]
124141
125142toJSHeader :: HeaderArg -> Text
126−toJSHeader (HeaderArg n) = toValidFunctionName ("header" <> fst n)
143+toJSHeader (HeaderArg n)
144+ = toValidFunctionName ("header" <> n ^. aName . _PathSegment)
127145toJSHeader (ReplaceHeaderArg n p)
128146 | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\""
129147 | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv
@@ -131,8 +149,8 @@ toJSHeader (ReplaceHeaderArg n p)
131149 <> "\""
132150 | otherwise = p
133151 where
134− pv = toValidFunctionName ("header" <> fst n)
135− pn = "{" <> fst n <> "}"
152+ pv = toValidFunctionName ("header" <> n ^. aName . _PathSegment)
153+ pn = "{" <> n ^. aName . _PathSegment <> "}"
136154 rp = T.replace pn "" p
137155
138156jsSegments :: [Segment] -> Text
@@ -145,8 +163,9 @@ segmentToStr (Segment st) notTheEnd =
145163 segmentTypeToStr st <> if notTheEnd then "" else "'"
146164
147165segmentTypeToStr :: SegmentType -> Text
148−segmentTypeToStr (Static s) = s
149−segmentTypeToStr (Cap s) = "' + encodeURIComponent(" <> fst s <> ") + '"
166+segmentTypeToStr (Static s) = s ^. _PathSegment
167+segmentTypeToStr (Cap s) =
168+ "' + encodeURIComponent(" <> s ^. aName . _PathSegment <> ") + '"
150169
151170jsGParams :: Text -> [QueryArg] -> Text
152171jsGParams _ [] = ""
@@ -168,4 +187,4 @@ paramToStr qarg notTheEnd =
168187 <> "[]=' + encodeURIComponent("
169188 <> name
170189 <> 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)
1010import Servant.Foreign
1111import Servant.JS.Internal
1212
13+
1314-- | Generate javascript functions that use the /jQuery/ library
1415-- to make the AJAX calls. Uses 'defCommonGeneratorOptions'
1516-- for the generator options.
@@ -42,12 +43,15 @@ generateJQueryJSWith opts req = "\n" <>
4243
4344 where argsStr = T.intercalate ", " args
4445 args = captures
45− ++ map (view $ argName._1) queryparams
46+ ++ map (view $ argName . aPath) queryparams
4647 ++ body
47− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs
48+ ++ map (toValidFunctionName
49+ . (<>) "header"
50+ . view (headerArg . aPath)
51+ ) hs
4852 ++ [onSuccess, onError]
4953
50− captures = map (fst . captureArg)
54+ captures = map (view aPath . captureArg)
5155 . filter isCapture
5256 $ req ^. reqUrl.path
5357
@@ -73,10 +77,11 @@ generateJQueryJSWith opts req = "\n" <>
7377 then ""
7478 else " , headers: { " <> headersStr <> " }\n"
7579
76− where headersStr = T.intercalate ", " $ map headerStr hs
77− headerStr header = "\"" <>
78− fst (headerArg header) <>
79− "\": " <> toJSHeader header
80+ where
81+ headersStr = T.intercalate ", " $ map headerStr hs
82+ headerStr header = "\"" <>
83+ header ^. headerArg . aPath <>
84+ "\": " <> toJSHeader header
8085
8186 namespace = if (moduleName opts) == ""
8287 then "var "
servant-js/src/Servant/JS/Vanilla.hs+11−7
@@ -54,12 +54,15 @@ generateVanillaJSWith opts req = "\n" <>
5454
5555 where argsStr = T.intercalate ", " args
5656 args = captures
57− ++ map (view $ argName._1) queryparams
57+ ++ map (view $ argName . aPath) queryparams
5858 ++ body
59− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs
59+ ++ map ( toValidFunctionName
60+ . (<>) "header"
61+ . view (headerArg . aPath)
62+ ) hs
6063 ++ [onSuccess, onError]
6164
62− captures = map (fst . captureArg)
65+ captures = map (view aPath . captureArg)
6366 . filter isCapture
6467 $ req ^. reqUrl.path
6568
@@ -85,10 +88,11 @@ generateVanillaJSWith opts req = "\n" <>
8588 then ""
8689 else headersStr <> "\n"
8790
88− where headersStr = T.intercalate "\n" $ map headerStr hs
89− headerStr header = " xhr.setRequestHeader(\"" <>
90− fst (headerArg header) <>
91− "\", " <> toJSHeader header <> ");"
91+ where
92+ headersStr = T.intercalate "\n" $ map headerStr hs
93+ headerStr header = " xhr.setRequestHeader(\"" <>
94+ header ^. headerArg . aPath <>
95+ "\", " <> toJSHeader header <> ");"
9296
9397 namespace = if moduleName opts == ""
9498 then "var "
servant-js/test/Servant/JSSpec/CustomHeaders.hs+5−4
@@ -27,8 +27,9 @@ instance (KnownSymbol sym, HasForeign lang sublayout)
2727 type Foreign (Authorization sym a :> sublayout) = Foreign sublayout
2828
2929 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $
30− req & reqHeaders <>~ [ ReplaceHeaderArg ("Authorization", "") $
31− tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ]
30+ req & reqHeaders <>~
31+ [ ReplaceHeaderArg (Arg "Authorization" "")
32+ $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ]
3233 where
3334 tokenType t = t <> " {Authorization}"
3435
@@ -40,7 +41,7 @@ instance (HasForeign lang sublayout)
4041 type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout
4142
4243 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $
43− req & reqHeaders <>~ [ ReplaceHeaderArg ("X-MyLovelyHorse", "") tpl ]
44+ req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" "") tpl ]
4445 where
4546 tpl = "I am good friends with {X-MyLovelyHorse}"
4647
@@ -52,6 +53,6 @@ instance (HasForeign lang sublayout)
5253 type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout
5354
5455 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $
55− req & reqHeaders <>~ [ ReplaceHeaderArg ("X-WhatsForDinner", "") tpl ]
56+ req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" "") tpl ]
5657 where
5758 tpl = "I would like {X-WhatsForDinner} with a cherry on top."