git.iko.soy/typeable/servant
on master help sign in
[servant-foreign] Parameterise Req with a foreign type
207f05eSteve Purcell
servant-foreign/servant-foreign.cabal+2
compare with master
unifiedsplit
@@ -46,6 +46,7 @@ library
46 , GeneralizedNewtypeDeriving
46 , GeneralizedNewtypeDeriving
47 , MultiParamTypeClasses
47 , MultiParamTypeClasses
48 , ScopedTypeVariables
48 , ScopedTypeVariables
49+ , StandaloneDeriving
49 , TemplateHaskell
50 , TemplateHaskell
50 , TypeFamilies
51 , TypeFamilies
51 , TypeOperators
52 , TypeOperators
@@ -64,6 +65,7 @@ test-suite spec
64 build-depends: base
65 build-depends: base
65 , hspec >= 2.1.8
66 , hspec >= 2.1.8
66 , servant-foreign
67 , servant-foreign
68+ , text >= 1.2 && < 1.3
67 default-language: Haskell2010
69 default-language: Haskell2010
68 default-extensions: ConstraintKinds
70 default-extensions: ConstraintKinds
69 , DataKinds
71 , DataKinds
servant-foreign/src/Servant/Foreign/Internal.hs+62−40
@@ -27,8 +27,12 @@ newtype FunctionName = FunctionName { unFunctionName :: [Text] }
27
27
28makePrisms ''FunctionName
28makePrisms ''FunctionName
29
29
30−newtype ForeignType = ForeignType { unForeignType :: Text }
30+newtype ForeignType f = ForeignType { unForeignType :: f }
31− deriving (Show, Eq, IsString, Monoid)
31+
32+deriving instance Show f => Show (ForeignType f)
33+deriving instance Eq f => Eq (ForeignType f)
34+deriving instance IsString f => IsString (ForeignType f)
35+deriving instance Monoid f => Monoid (ForeignType f)
32
36
33makePrisms ''ForeignType
37makePrisms ''ForeignType
34
38
@@ -37,39 +41,45 @@ newtype PathSegment = PathSegment { unPathSegment :: Text }
37
41
38makePrisms ''PathSegment
42makePrisms ''PathSegment
39
43
40−data Arg = Arg
44+data Arg f = Arg
41 { _argName :: PathSegment
45 { _argName :: PathSegment
42− , _argType :: ForeignType }
46+ , _argType :: ForeignType f }
47+
43− deriving (Show, Eq)
48+deriving instance Eq f => Eq (Arg f)
49+deriving instance Show f => Show (Arg f)
44
50
45makeLenses ''Arg
51makeLenses ''Arg
46
52
47−argPath :: Getter Arg Text
53+argPath :: Getter (Arg f) Text
48argPath = argName . _PathSegment
54argPath = argName . _PathSegment
49
55
50−data SegmentType
56+data SegmentType f
51 = Static PathSegment
57 = Static PathSegment
52 -- ^ a static path segment. like "/foo"
58 -- ^ a static path segment. like "/foo"
53− | Cap Arg
59+ | Cap (Arg f)
54 -- ^ a capture. like "/:userid"
60 -- ^ a capture. like "/:userid"
55− deriving (Show, Eq)
61+
62+deriving instance Eq f => Eq (SegmentType f)
63+deriving instance Show f => Show (SegmentType f)
56
64
57makePrisms ''SegmentType
65makePrisms ''SegmentType
58
66
59−newtype Segment = Segment { unSegment :: SegmentType }
67+newtype Segment f = Segment { unSegment :: SegmentType f }
68+
60− deriving (Eq, Show)
69+deriving instance Eq f => Eq (Segment f)
70+deriving instance Show f => Show (Segment f)
61
71
62makePrisms ''Segment
72makePrisms ''Segment
63
73
64−isCapture :: Segment -> Bool
74+isCapture :: Segment f -> Bool
65isCapture (Segment (Cap _)) = True
75isCapture (Segment (Cap _)) = True
66isCapture _ = False
76isCapture _ = False
67
77
68−captureArg :: Segment -> Arg
78+captureArg :: Segment f -> Arg f
69captureArg (Segment (Cap s)) = s
79captureArg (Segment (Cap s)) = s
70captureArg _ = error "captureArg called on non capture"
80captureArg _ = error "captureArg called on non capture"
71
81
72−type Path = [Segment]
82+type Path f = [Segment f]
73
83
74data ArgType
84data ArgType
75 = Normal
85 = Normal
@@ -79,46 +89,58 @@ data ArgType
79
89
80makePrisms ''ArgType
90makePrisms ''ArgType
81
91
82−data QueryArg = QueryArg
92+data QueryArg f = QueryArg
83− { _queryArgName :: Arg
93+ { _queryArgName :: Arg f
84 , _queryArgType :: ArgType
94 , _queryArgType :: ArgType
95+ }
96+
97+deriving instance Eq f => Eq (QueryArg f)
85− } deriving (Eq, Show)
98+deriving instance Show f => Show (QueryArg f)
86
99
87makeLenses ''QueryArg
100makeLenses ''QueryArg
88
101
89−data HeaderArg = HeaderArg
102+data HeaderArg f = HeaderArg
90− { _headerArg :: Arg }
103+ { _headerArg :: Arg f }
91 | ReplaceHeaderArg
104 | ReplaceHeaderArg
92− { _headerArg :: Arg
105+ { _headerArg :: Arg f
93 , _headerPattern :: Text
106 , _headerPattern :: Text
107+ }
108+
109+deriving instance Eq f => Eq (HeaderArg f)
94− } deriving (Eq, Show)
110+deriving instance Show f => Show (HeaderArg f)
95
111
96makeLenses ''HeaderArg
112makeLenses ''HeaderArg
97
113
98makePrisms ''HeaderArg
114makePrisms ''HeaderArg
99
115
100−data Url = Url
116+data Url f = Url
101− { _path :: Path
117+ { _path :: Path f
102− , _queryStr :: [QueryArg]
118+ , _queryStr :: [QueryArg f]
103− } deriving (Eq, Show)
119+ }
104
120
121+deriving instance Eq f => Eq (Url f)
122+deriving instance Show f => Show (Url f)
123+
105−defUrl :: Url
124+defUrl :: Url f
106defUrl = Url [] []
125defUrl = Url [] []
107
126
108makeLenses ''Url
127makeLenses ''Url
109
128
110−data Req = Req
129+data Req f = Req
111− { _reqUrl :: Url
130+ { _reqUrl :: Url f
112 , _reqMethod :: HTTP.Method
131 , _reqMethod :: HTTP.Method
113− , _reqHeaders :: [HeaderArg]
132+ , _reqHeaders :: [HeaderArg f]
114− , _reqBody :: Maybe ForeignType
133+ , _reqBody :: Maybe (ForeignType f)
115− , _reqReturnType :: ForeignType
134+ , _reqReturnType :: ForeignType f
116 , _reqFuncName :: FunctionName
135 , _reqFuncName :: FunctionName
136+ }
137+
138+deriving instance Eq f => Eq (Req f)
117− } deriving (Eq, Show)
139+deriving instance Show f => Show (Req f)
118
140
119makeLenses ''Req
141makeLenses ''Req
120
142
121−defReq :: Req
143+defReq :: Req Text
122defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName [])
144defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName [])
123
145
124-- | To be used exclusively as a "negative" return type/constraint
146-- | To be used exclusively as a "negative" return type/constraint
@@ -161,7 +183,7 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
161-- >
183-- >
162--
184--
163class HasForeignType lang a where
185class HasForeignType lang a where
164− typeFor :: Proxy lang -> Proxy a -> ForeignType
186+ typeFor :: Proxy lang -> Proxy a -> ForeignType Text
165
187
166data NoTypes
188data NoTypes
167
189
@@ -172,7 +194,7 @@ type HasNoForeignType = HasForeignType NoTypes
172
194
173class HasForeign lang (layout :: *) where
195class HasForeign lang (layout :: *) where
174 type Foreign layout :: *
196 type Foreign layout :: *
175− foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout
197+ foreignFor :: Proxy lang -> Proxy layout -> Req Text -> Foreign layout
176
198
177instance (HasForeign lang a, HasForeign lang b)
199instance (HasForeign lang a, HasForeign lang b)
178 => HasForeign lang (a :<|> b) where
200 => HasForeign lang (a :<|> b) where
@@ -199,7 +221,7 @@ instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout)
199
221
200instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
222instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
201 => HasForeign lang (Verb method status list a) where
223 => HasForeign lang (Verb method status list a) where
202− type Foreign (Verb method status list a) = Req
224+ type Foreign (Verb method status list a) = Req Text
203
225
204 foreignFor lang Proxy req =
226 foreignFor lang Proxy req =
205 req & reqFuncName . _FunctionName %~ (methodLC :)
227 req & reqFuncName . _FunctionName %~ (methodLC :)
@@ -264,7 +286,7 @@ instance
264 , _argType = typeFor lang (Proxy :: Proxy Bool) }
286 , _argType = typeFor lang (Proxy :: Proxy Bool) }
265
287
266instance HasForeign lang Raw where
288instance HasForeign lang Raw where
267− type Foreign Raw = HTTP.Method -> Req
289+ type Foreign Raw = HTTP.Method -> Req Text
268
290
269 foreignFor _ Proxy req method =
291 foreignFor _ Proxy req method =
270 req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
292 req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
@@ -329,9 +351,9 @@ instance HasForeign lang sublayout
329-- the data needed to generate a function for each endpoint
351-- the data needed to generate a function for each endpoint
330-- and hands it all back in a list.
352-- and hands it all back in a list.
331class GenerateList reqs where
353class GenerateList reqs where
332− generateList :: reqs -> [Req]
354+ generateList :: reqs -> [Req Text]
333
355
334−instance GenerateList Req where
356+instance GenerateList (Req Text) where
335 generateList r = [r]
357 generateList r = [r]
336
358
337instance (GenerateList start, GenerateList rest)
359instance (GenerateList start, GenerateList rest)
@@ -344,5 +366,5 @@ listFromAPI
344 :: (HasForeign lang api, GenerateList (Foreign api))
366 :: (HasForeign lang api, GenerateList (Foreign api))
345 => Proxy lang
367 => Proxy lang
346 -> Proxy api
368 -> Proxy api
347− -> [Req]
369+ -> [Req Text]
348listFromAPI lang p = generateList (foreignFor lang p defReq)
370listFromAPI lang p = generateList (foreignFor lang p defReq)
servant-foreign/test/Servant/ForeignSpec.hs+2−1
@@ -6,6 +6,7 @@ module Servant.ForeignSpec where
6import Data.Monoid ((<>))
6import Data.Monoid ((<>))
7import Data.Proxy
7import Data.Proxy
8import Servant.Foreign
8import Servant.Foreign
9+import Data.Text (Text(..))
9
10
10import Test.Hspec
11import Test.Hspec
11
12
@@ -47,7 +48,7 @@ type TestApi
47 :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] ()
48 :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] ()
48 :<|> "test" :> Capture "id" Int :> Delete '[JSON] ()
49 :<|> "test" :> Capture "id" Int :> Delete '[JSON] ()
49
50
50−testApi :: [Req]
51+testApi :: [Req Text]
51testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi)
52testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi)
52
53
53listFromAPISpec :: Spec
54listFromAPISpec :: Spec
servant-js/src/Servant/JS/Internal.hs+9−9
@@ -57,12 +57,12 @@ import qualified Data.Text as T
57import Data.Text (Text)
57import Data.Text (Text)
58import Servant.Foreign
58import Servant.Foreign
59
59
60−type AjaxReq = Req
60+type AjaxReq = Req Text
61
61
62-- A 'JavascriptGenerator' just takes the data found in the API type
62-- A 'JavascriptGenerator' just takes the data found in the API type
63-- for each endpoint and generates Javascript code in a Text. Several
63-- for each endpoint and generates Javascript code in a Text. Several
64-- generators are available in this package.
64-- generators are available in this package.
65−type JavaScriptGenerator = [Req] -> Text
65+type JavaScriptGenerator = [Req Text] -> Text
66
66
67-- | This structure is used by specific implementations to let you
67-- | This structure is used by specific implementations to let you
68-- customize the output
68-- customize the output
@@ -139,7 +139,7 @@ toValidFunctionName t =
139 , Set.connectorPunctuation
139 , Set.connectorPunctuation
140 ]
140 ]
141
141
142−toJSHeader :: HeaderArg -> Text
142+toJSHeader :: HeaderArg f -> Text
143toJSHeader (HeaderArg n)
143toJSHeader (HeaderArg n)
144 = toValidFunctionName ("header" <> n ^. argName . _PathSegment)
144 = toValidFunctionName ("header" <> n ^. argName . _PathSegment)
145toJSHeader (ReplaceHeaderArg n p)
145toJSHeader (ReplaceHeaderArg n p)
@@ -153,29 +153,29 @@ toJSHeader (ReplaceHeaderArg n p)
153 pn = "{" <> n ^. argName . _PathSegment <> "}"
153 pn = "{" <> n ^. argName . _PathSegment <> "}"
154 rp = T.replace pn "" p
154 rp = T.replace pn "" p
155
155
156−jsSegments :: [Segment] -> Text
156+jsSegments :: [Segment f] -> Text
157jsSegments [] = ""
157jsSegments [] = ""
158jsSegments [x] = "/" <> segmentToStr x False
158jsSegments [x] = "/" <> segmentToStr x False
159jsSegments (x:xs) = "/" <> segmentToStr x True <> jsSegments xs
159jsSegments (x:xs) = "/" <> segmentToStr x True <> jsSegments xs
160
160
161−segmentToStr :: Segment -> Bool -> Text
161+segmentToStr :: Segment f -> Bool -> Text
162segmentToStr (Segment st) notTheEnd =
162segmentToStr (Segment st) notTheEnd =
163 segmentTypeToStr st <> if notTheEnd then "" else "'"
163 segmentTypeToStr st <> if notTheEnd then "" else "'"
164
164
165−segmentTypeToStr :: SegmentType -> Text
165+segmentTypeToStr :: SegmentType f -> Text
166segmentTypeToStr (Static s) = s ^. _PathSegment
166segmentTypeToStr (Static s) = s ^. _PathSegment
167segmentTypeToStr (Cap s) =
167segmentTypeToStr (Cap s) =
168 "' + encodeURIComponent(" <> s ^. argName . _PathSegment <> ") + '"
168 "' + encodeURIComponent(" <> s ^. argName . _PathSegment <> ") + '"
169
169
170−jsGParams :: Text -> [QueryArg] -> Text
170+jsGParams :: Text -> [QueryArg f] -> Text
171jsGParams _ [] = ""
171jsGParams _ [] = ""
172jsGParams _ [x] = paramToStr x False
172jsGParams _ [x] = paramToStr x False
173jsGParams s (x:xs) = paramToStr x True <> s <> jsGParams s xs
173jsGParams s (x:xs) = paramToStr x True <> s <> jsGParams s xs
174
174
175−jsParams :: [QueryArg] -> Text
175+jsParams :: [QueryArg f] -> Text
176jsParams = jsGParams "&"
176jsParams = jsGParams "&"
177
177
178−paramToStr :: QueryArg -> Bool -> Text
178+paramToStr :: QueryArg f -> Bool -> Text
179paramToStr qarg notTheEnd =
179paramToStr qarg notTheEnd =
180 case qarg ^. queryArgType of
180 case qarg ^. queryArgType of
181 Normal -> name
181 Normal -> name