@@ -15,21 +15,20 @@ module Gen.Syntax where
1515import Control.Lens hiding (iso, mapping, op, pre,
1616 strict)
1717import Data.Either
18−import Data.Foldable (find, foldl', foldr')
19−import Data.Hashable
18+import Data.Foldable (foldl', foldr')
2019import qualified Data.HashMap.Strict as Map
2120import Data.List (delete, nub)
2221import Data.Maybe
2322import Data.Semigroup ((<>))
24−import Data.String
2523import Data.Text (Text)
2624import qualified Data.Text as Text
2725import Data.Text.Manipulate
28−import Debug.Trace
29−import Gen.Orphans
3026import Gen.Text
3127import Gen.Types
32−import Language.Haskell.Exts.Build
28+import Language.Haskell.Exts.Build (app, appFun, infixApp, lamE,
29+ listE, name, noBinds, paren,
30+ patBind, pvar, sfun, strE, sym,
31+ var)
3332import Language.Haskell.Exts.SrcLoc
3433import Language.Haskell.Exts.Syntax hiding (Alt, Int, Lit)
3534
@@ -174,6 +173,7 @@ httpMethod = TyCon . unqual . Text.unpack . Text.toTitle . _mHttpMethod
174173subPaths :: Text -> [Type]
175174subPaths = map sing . filter (not . Text.null) . Text.split (== '/')
176175
176+jsonMedia, streamMedia :: Type
177177jsonMedia = tylist ["JSON"]
178178streamMedia = tylist ["OctetStream"]
179179
@@ -187,10 +187,12 @@ uploadParam =
187187 TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))
188188 (TyCon "AltMedia")
189189
190+metadataPat, downloadPat, uploadPat :: Method a -> Pat
190191metadataPat = pattern 1
191192downloadPat = pattern 2
192193uploadPat = pattern 3
193194
195+pattern :: Integer -> Method a -> Pat
194196pattern n m = case (n, down, up) of
195197 (1, True, True) -> infixOr go (infixOr wild wild)
196198 (2, True, True) -> infixOr wild (infixOr go wild)
@@ -219,8 +221,8 @@ downloadDecl :: Global
219221 -> [Local]
220222 -> Method Solved
221223 -> Decl
222−downloadDecl n p api url fs m =
223− googleRequestDecl n ty [rs, ss] [alt] p api url fs m pat prec
224+downloadDecl n pre api url fs m =
225+ googleRequestDecl ty [rs, ss] [alt] pre api url m pat prec
224226 where
225227 ty = TyApp (TyCon "MediaDownload") (tycon n)
226228
@@ -243,8 +245,8 @@ uploadDecl :: Global
243245 -> [Local]
244246 -> Method Solved
245247 -> Decl
246−uploadDecl n p api url fs m =
247− googleRequestDecl n ty [rs, ss] extras p api url fs m pat prec
248+uploadDecl n pre api url fs m =
249+ googleRequestDecl ty [rs, ss] extras pre api url m pat prec
248250 where
249251 ty = TyApp (TyCon "MediaUpload") (tycon n)
250252
@@ -261,7 +263,7 @@ uploadDecl n p api url fs m =
261263 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
262264
263265 payload
264− | isJust (_mRequest m) = [var (fname p "payload")]
266+ | isJust (_mRequest m) = [var (fname pre "payload")]
265267 | otherwise = []
266268
267269 pat = uploadPat m
@@ -280,8 +282,8 @@ requestDecl :: Global
280282 -> [Local]
281283 -> Method Solved
282284 -> Decl
283−requestDecl n p api url fs m =
284− googleRequestDecl n (tycon n) [rs, ss] extras p api url fs m pat prec
285+requestDecl n pre api url fs m =
286+ googleRequestDecl (tycon n) [rs, ss] extras pre api url m pat prec
285287 where
286288 rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
287289 maybe unit_tycon (tycon . ref) (_mResponse m)
@@ -297,26 +299,24 @@ requestDecl n p api url fs m =
297299 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
298300
299301 payload
300− | isJust (_mRequest m) = Just $ var (fname p "payload")
302+ | isJust (_mRequest m) = Just $ var (fname pre "payload")
301303 | otherwise = Nothing
302304
303305 pat = metadataPat m
304306
305307 prec = PRec (UnQual (dname n)) [PFieldWildcard | not (null fs)]
306308
307−googleRequestDecl :: Global
308− -> Type
309+googleRequestDecl :: Type
309310 -> [InstDecl]
310311 -> [Exp]
311312 -> Prefix
312313 -> Name
313314 -> Name
314− -> [Local]
315315 -> Method Solved
316316 -> Pat
317317 -> Pat
318318 -> Decl
319−googleRequestDecl g n assoc extras p api url fields m pat prec =
319+googleRequestDecl n assoc extras pre api url m pat prec =
320320 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n] (assoc ++ [request])
321321 where
322322 request = InsDecl (FunBind [match])
@@ -350,7 +350,7 @@ googleRequestDecl g n assoc extras p api url fields m pat prec =
350350 _ -> v l
351351
352352 ps = _mParameters m
353− v = var . fname p
353+ v = var . fname pre
354354
355355 fs = delete "alt"
356356 . orderParams id (Map.keys (_mParameters m))
@@ -358,9 +358,9 @@ googleRequestDecl g n assoc extras p api url fields m pat prec =
358358 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m
359359
360360jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
361−jsonDecls g p (Map.toList -> rs) = [from, to]
361+jsonDecls g p (Map.toList -> rs) = [from', to']
362362 where
363− from = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
363+ from' = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
364364 [ funD "parseJSON" $
365365 app (app (var "withObject") (dstr g)) $
366366 lamE noLoc [pvar "o"] $
@@ -374,7 +374,7 @@ jsonDecls g p (Map.toList -> rs) = [from, to]
374374 | monoid s = defJS l (var "mempty")
375375 | otherwise = optJS l
376376
377− to = case rs of
377+ to' = case rs of
378378 [(k, v)] | _additional v ->
379379 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
380380 [ funD "toJSON" $
@@ -383,14 +383,14 @@ jsonDecls g p (Map.toList -> rs) = [from, to]
383383
384384 _ ->
385385 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
386− [ wildcardD "toJSON" g omit none (map encode rs)
386+ [ wildcardD "toJSON" g omit emptyObj (map encode rs)
387387 ]
388388
389389 omit = app (var "object")
390390 . app (var "catMaybes")
391391 . listE
392392
393− none = var "emptyObject"
393+ emptyObj = var "emptyObject"
394394
395395 encode (l, s)
396396 | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a