git.iko.soy/gogol
on ce42607 help sign in
gogol/gen/src/Gen/Syntax.hs
643 lines 20 kB history raw
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TupleSections #-}
4{-# LANGUAGE ViewPatterns #-}
6-- Module : Gen.Syntax
7-- Copyright : (c) 2015-2016 Brendan Hay
8-- License : Mozilla Public License, v. 2.0.
9-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
10-- Stability : provisional
11-- Portability : non-portable (GHC extensions)
13module Gen.Syntax where
15import Control.Lens hiding (iso, mapping, op, pre,
16 strict)
17import Data.Either
18import Data.Foldable (foldl', foldr')
19import qualified Data.HashMap.Strict as Map
20import Data.List (delete, nub)
21import Data.Maybe
22import Data.Semigroup ((<>))
23import Data.Text (Text)
24import qualified Data.Text as Text
25import Data.Text.Manipulate
26import Gen.Text
27import Gen.Types
28import Language.Haskell.Exts.Build (app, appFun, infixApp, lamE,
29 listE, name, noBinds, paren,
30 patBind, pvar, sfun, strE, sym,
31 var)
32import Language.Haskell.Exts.SrcLoc
33import Language.Haskell.Exts.Syntax hiding (Alt, Int, Lit)
35serviceSig :: Name -> Decl
36serviceSig n = TypeSig noLoc [n] (TyCon "ServiceConfig")
38serviceDecl :: Service a -> Name -> Decl
39serviceDecl s n = sfun noLoc n [] (UnGuardedRhs rhs) noBinds
40 where
41 rhs = appFun (var "defaultService")
42 [ app (var "ServiceId") (str (s ^. dId))
43 , str . stripSuffix "/" $ stripPrefix "https://" (s ^. dRootUrl)
44 ]
46scopeSig :: Name -> Text -> Decl
47scopeSig n v = TypeSig noLoc [n] $
48 TyApp (TyCon "Proxy") $
49 TyPromoted $ PromotedList True
50 [ TyPromoted $ PromotedString (Text.unpack v)
51 ]
53scopeDecl :: Name -> Decl
54scopeDecl n = sfun noLoc n [] (UnGuardedRhs (var "Proxy")) noBinds
56apiAlias :: Name -> [Name] -> Decl
57apiAlias n ls = TypeDecl noLoc n [] alias
58 where
59 alias = case map (TyCon . UnQual) ls of
60 [] -> unit_tycon
61 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
63verbAlias :: HasDescription a s => a -> Name -> Method Solved -> Decl
64verbAlias d n m = TypeDecl noLoc n [] $ servantOr meta (catMaybes [down, up])
65 where
66 meta = path $ metadataAlias m
67 down = path <$> downloadAlias m
68 up = uploadAlias root m
70 path = flip servantSub root
72 root = subPaths (d ^. dServicePath) ++ requestPath m (_mPath m)
74metadataAlias :: Method Solved -> Type
75metadataAlias m = servantSub (jsonVerb m) (params ++ media)
76 where
77 params = requestQuery m (requestQueryParams m)
78 media = case _mRequest m of
79 Nothing -> []
80 Just b ->
81 [ TyApp (TyApp (TyCon "ReqBody") jsonMedia)
82 (tycon (ref b))
83 ]
85downloadAlias :: Method Solved -> Maybe Type
86downloadAlias m
87 | _mSupportsMediaDownload m = Just download
88 | otherwise = Nothing
89 where
90 download = servantSub (downloadVerb m) (params ++ [altParam])
92 params = requestQuery m . Map.delete "alt" $ requestQueryParams m
94uploadAlias :: [Type] -> Method Solved -> Maybe Type
95uploadAlias sub m
96 | _mSupportsMediaUpload m = Just upload
97 | otherwise = Nothing
98 where
99 upload = servantSub (jsonVerb m) (path ++ params ++ [uploadParam, media])
101 params = requestQuery m (requestQueryParams m)
103 path = case _mMediaUpload m of
104 Nothing -> sub
105 Just u -> requestPath m (_muSimplePath u)
107 media = case _mRequest m of
108 Just b ->
109 TyApp (TyApp (TyApp (TyCon "MultipartRelated") jsonMedia)
110 (tycon (ref b)))
111 (TyCon "RequestBody")
113 Nothing ->
114 TyApp (TyApp (TyCon "ReqBody") streamMedia)
115 (TyCon "RequestBody")
117requestPath :: Method Solved -> Text -> [Type]
118requestPath m = map go . extractPath
119 where
120 go (Left t) = sing t
121 go (Right (l, c)) = case Map.lookup l (_mParameters m) of
122 Nothing -> error $ "Unable to find path parameter " ++ show l
123 Just x -> case c of
124 Nothing | x ^. iRepeated ->
125 TyApp (TyApp (TyCon "Captures")
126 (sing (local l)))
127 (terminalType (_type (_pParam x)))
129 Nothing ->
130 TyApp (TyApp (TyCon "Capture")
131 (sing (local l)))
132 (terminalType (_type (_pParam x)))
134 Just y ->
135 TyApp (TyApp (TyApp (TyCon "CaptureMode")
136 (sing (local l)))
137 (sing y))
138 (terminalType (_type (_pParam x)))
140requestQuery :: Method Solved -> Map Local (Param Solved) -> [Type]
141requestQuery m xs = mapMaybe go $
142 orderParams fst (Map.toList xs) (_mParameterOrder m)
143 where
144 go (k, x) = case _pLocation x of
145 Query | x ^. iRepeated
146 -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t
147 Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t
148 Path -> Nothing
149 where
150 t = terminalType (_type (_pParam x))
151 n = sing (local k)
153requestQueryParams :: Method a -> Map Local (Param a)
154requestQueryParams = Map.filter ((/= Path) . _pLocation) . _mParameters
156servantOr, servantSub :: Type -> [Type] -> Type
157servantOr = foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r)
158servantSub = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r)
160jsonVerb :: Method a -> Type
161jsonVerb m =
162 TyApp (TyApp (httpMethod m) jsonMedia)
163 $ maybe (TyCon "()") (tycon . ref) (_mResponse m)
165downloadVerb :: Method a -> Type
166downloadVerb m =
167 TyApp (TyApp (httpMethod m) streamMedia)
168 (TyCon "Stream")
170httpMethod :: Method a -> Type
171httpMethod = TyCon . unqual . Text.unpack . Text.toTitle . _mHttpMethod
173subPaths :: Text -> [Type]
174subPaths = map sing . filter (not . Text.null) . Text.split (== '/')
176jsonMedia, streamMedia :: Type
177jsonMedia = tylist ["JSON"]
178streamMedia = tylist ["OctetStream"]
180altParam :: Type
181altParam =
182 TyApp (TyApp (TyCon "QueryParam") (sing "alt"))
183 (TyCon "AltMedia")
185uploadParam :: Type
186uploadParam =
187 TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))
188 (TyCon "AltMedia")
190metadataPat, downloadPat, uploadPat :: Method a -> Pat
191metadataPat = pattern 1
192downloadPat = pattern 2
193uploadPat = pattern 3
195pattern :: Integer -> Method a -> Pat
196pattern n m = case (n, down, up) of
197 (1, True, True) -> infixOr go (infixOr wild wild)
198 (2, True, True) -> infixOr wild (infixOr go wild)
199 (_, True, True) -> infixOr wild (infixOr wild go)
201 (1, True, _) -> infixOr go wild
202 (_, True, _) -> infixOr wild go
204 (1, _, True) -> infixOr go wild
205 (_, _, True) -> infixOr wild go
207 (_, _, _) -> go
208 where
209 down = _mSupportsMediaDownload m
210 up = _mSupportsMediaUpload m
212 go = pvar "go"
213 wild = PWildCard
215 infixOr l r = PInfixApp l (UnQual (sym ":<|>")) r
217downloadDecl :: Global
218 -> Prefix
219 -> Name
220 -> Name
221 -> [Local]
222 -> Method Solved
223 -> Decl
224downloadDecl n pre api url fs m =
225 googleRequestDecl ty [rs, ss] [alt] pre api url m pat prec
226 where
227 ty = TyApp (TyCon "MediaDownload") (tycon n)
229 rs = InsType noLoc (TyApp (TyCon "Rs") ty) (TyCon "Stream")
231 ss = InsType noLoc (TyApp (TyCon "Scopes") ty) $
232 TyApp (TyCon "Scopes") (tycon n)
234 alt = app (var "Just") (var "AltMedia")
235 pat = downloadPat m
237 prec = PApp (UnQual "MediaDownload")
238 [ PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]
239 ]
241uploadDecl :: Global
242 -> Prefix
243 -> Name
244 -> Name
245 -> [Local]
246 -> Method Solved
247 -> Decl
248uploadDecl n pre api url fs m =
249 googleRequestDecl ty [rs, ss] extras pre api url m pat prec
250 where
251 ty = TyApp (TyCon "MediaUpload") (tycon n)
253 rs = InsType noLoc (TyApp (TyCon "Rs") ty) $
254 maybe unit_tycon (tycon . ref) (_mResponse m)
256 ss = InsType noLoc (TyApp (TyCon "Scopes") ty) $
257 TyApp (TyCon "Scopes") (tycon n)
259 extras = maybeToList alt ++ [upl] ++ payload ++ [var media]
260 where
261 upl = app (var "Just") (var "AltMedia")
262 alt = app (var "Just") . var . name . Text.unpack . alternate <$>
263 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
265 payload
266 | isJust (_mRequest m) = [var (fname pre "payload")]
267 | otherwise = []
269 pat = uploadPat m
271 prec = PApp (UnQual "MediaUpload")
272 [ PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]
273 , PVar media
274 ]
276 media = name "body"
278requestDecl :: Global
279 -> Prefix
280 -> Name
281 -> Name
282 -> [Local]
283 -> Method Solved
284 -> Decl
285requestDecl n pre api url fs m =
286 googleRequestDecl (tycon n) [rs, ss] extras pre api url m pat prec
287 where
288 rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
289 maybe unit_tycon (tycon . ref) (_mResponse m)
291 ss = InsType noLoc (TyApp (TyCon "Scopes") (tycon n)) $
292 TyPromoted $
293 PromotedList True $
294 map (TyPromoted . PromotedString . Text.unpack) (_mScopes m)
296 extras = catMaybes [alt, payload]
297 where
298 alt = app (var "Just") . var . name . Text.unpack . alternate <$>
299 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
301 payload
302 | isJust (_mRequest m) = Just $ var (fname pre "payload")
303 | otherwise = Nothing
305 pat = metadataPat m
307 prec = PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]
309googleRequestDecl :: Type
310 -> [InstDecl]
311 -> [Exp]
312 -> Prefix
313 -> Name
314 -> Name
315 -> Method Solved
316 -> Pat
317 -> Pat
318 -> Decl
319googleRequestDecl n assoc extras pre api url m pat prec =
320 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n] (assoc ++ [request])
321 where
322 request = InsDecl (FunBind [match])
324 match = Match noLoc (name "requestClient") [prec] Nothing rhs (Just decls)
326 decls = BDecls
327 [ patBind noLoc pat $
328 appFun (var "buildClient") $
329 [ ExpTypeSig noLoc (var "Proxy") $
330 TyApp (TyCon "Proxy") (TyCon (UnQual api))
331 , var "mempty"
332 ]
333 ]
335 rhs = UnGuardedRhs . appFun (var "go") $ map go fs ++ extras ++ [var url]
336 where
337 go l = case Map.lookup l ps of
338 Just p | _pLocation p == Query
339 , defaulted p
340 , p ^. iRepeated -> v l
342 Just p | _pLocation p == Query
343 , not (required p)
344 , p ^. iRepeated -> infixApp (v l) "^." (var "_Default")
346 Just p | _pLocation p == Query
347 , not (p ^. iRepeated)
348 , parameter p || defaulted p -> app (var "Just") (v l)
350 _ -> v l
352 ps = _mParameters m
353 v = var . fname pre
355 fs = delete "alt"
356 . orderParams id (Map.keys (_mParameters m))
357 . nub
358 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m
360jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
361jsonDecls g p (Map.toList -> rs) = [from', to']
362 where
363 from' = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
364 [ funD "parseJSON" $
365 app (app (var "withObject") (dstr g)) $
366 lamE noLoc [pvar "o"] $
367 ctorE g (map decode rs)
368 ]
370 decode (l, s)
371 | _additional s = app (var "parseJSONObject") (var "o")
372 | Just x <- def s = defJS l x
373 | required s = reqJS l
374 | monoid s = defJS l (var "mempty")
375 | otherwise = optJS l
377 to' = case rs of
378 [(k, v)] | _additional v ->
379 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
380 [ funD "toJSON" $
381 infixApp (var "toJSON") "." (var (fname p k))
382 ]
384 _ ->
385 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
386 [ wildcardD "toJSON" g omit emptyObj (map encode rs)
387 ]
389 omit = app (var "object")
390 . app (var "catMaybes")
391 . listE
393 emptyObj = var "emptyObject"
395 encode (l, s)
396 | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a
397 | otherwise = app (var "Just") (infixApp n ".=" a)
398 where
399 n = fstr l
400 a = var (fname p l)
401 o = var ".="
403wildcardD :: String
404 -> Global
405 -> ([Exp] -> Exp)
406 -> Exp
407 -> [Exp]
408 -> InstDecl
409wildcardD f n enc x = \case
410 [] -> constD f x
411 xs -> InsDecl (FunBind [match prec xs])
412 where
413 match p es =
414 Match noLoc (name f) [p] Nothing (UnGuardedRhs (enc es)) noBinds
416 prec = PRec (UnQual (dname' n)) [PFieldWildcard]
418defJS :: Local -> Exp -> Exp
419defJS n x = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!=" x
421reqJS :: Local -> Exp
422reqJS = infixApp (var "o") ".:" . fstr
424optJS :: Local -> Exp
425optJS = infixApp (var "o") ".:?" . fstr
427funD :: String -> Exp -> InstDecl
428funD f = InsDecl . patBind noLoc (pvar (name f))
430constD :: String -> Exp -> InstDecl
431constD f x = InsDecl $
432 sfun noLoc (name f) [] (UnGuardedRhs (app (var "const") x)) noBinds
434ctorE :: Global -> [Exp] -> Exp
435ctorE n = seqE (var (dname' n)) . map paren
437seqE :: Exp -> [Exp] -> Exp
438seqE l [] = app (var "pure") l
439seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
441objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl
442objDecl n p ds rs =
443 DataDecl noLoc arity [] (dname n) [] [conDecl (dname' n) p rs] (der ds)
444 where
445 arity | Map.size rs == 1 = NewType
446 | otherwise = DataType
448 der = map ((,[]) . unqual . drop 1 . show)
450conDecl :: Name -> Prefix -> Map Local Solved -> QualConDecl
451conDecl n p rs = QualConDecl noLoc [] [] body
452 where
453 body = case Map.toList rs of
454 [] -> ConDecl n []
455 [x] -> RecDecl n [field internalType x]
456 xs -> RecDecl n (map (field (strict . internalType)) xs)
458 field f (l, v) = ([fname p l], f (_type v))
460ctorSig :: Global -> Map Local Solved -> Decl
461ctorSig n rs = TypeSig noLoc [cname n] ts
462 where
463 ts = foldr' TyFun (TyCon (UnQual (dname n))) ps
464 ps = parameters (Map.elems rs)
466ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl
467ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
468 where
469 c = cname n
470 d = dname' n
472 rhs | Map.null rs = var d
473 | otherwise = RecConstr (UnQual d) $
474 map (uncurry (fieldUpdate p)) (Map.toList rs)
476 ps = map (pname p) . Map.keys $ Map.filter parameter rs
478fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate
479fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
480 where
481 rhs | Just x <- def s, s ^. iRepeated = listE [x]
482 | Just x <- def s = x
483 | Just x <- iso (_type s) = infixApp x "#" v
484 | parameter s = v
485 | otherwise = var (name "Nothing")
487 v = var (pname p l)
489lensSig :: Global -> Prefix -> Local -> Solved -> Decl
490lensSig n p l s = TypeSig noLoc [lname p l] $
491 TyApp (TyApp (TyCon "Lens'") (tycon n))
492 (externalType (_type s))
494lensDecl :: Prefix -> Local -> Solved -> Decl
495lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
496 where
497 f = fname p l
498 t = _type s
500 rhs = mapping t $
501 app (app (var "lens") (var f))
502 (paren (lamE noLoc [pvar "s", pvar "a"]
503 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
505parameters :: [Solved] -> [Type]
506parameters = map (externalType . _type) . filter parameter
508def :: Solved -> Maybe Exp
509def s
510 | Just x <- s ^. iDefault = Just (go x (_prefix s) (_schema s))
511 | otherwise = Nothing
512 where
513 go x p = \case
514 SEnm {} -> var (bname p x)
515 SLit _ Bool -> lit (upperHead x)
516 SLit _ Text -> str x
517 SLit {} -> lit x
518 e -> error $ "Unsupported default value: " ++ show e
520 lit = var . name . Text.unpack
522terminalType :: TType -> Type
523terminalType = internalType . go
524 where
525 go (TMaybe x) = go x
526 go (TList x) = go x
527 go x = x
529externalType :: TType -> Type
530externalType = \case
531 TType r -> tycon r
532 TMaybe t@TList {} -> externalType t
533 TMaybe t -> TyApp (TyCon "Maybe") (externalType t)
534 TList t -> TyList (externalType t)
535 TLit l -> externalLit l
536 TMap k v ->
537 TyApp (TyApp (TyCon "HashMap") (externalType k)) (externalType (require v))
539internalType :: TType -> Type
540internalType = \case
541 TType r -> tycon r
542 TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
543 TList t -> TyList (internalType t)
544 TLit l -> internalLit l
545 TMap k v ->
546 TyApp (TyApp (TyCon "HashMap") (internalType k)) (internalType (require v))
548externalLit :: Lit -> Type
549externalLit = \case
550 Text -> TyCon "Text"
551 Bool -> TyCon "Bool"
552 Time -> TyCon "TimeOfDay"
553 Date -> TyCon "Day"
554 DateTime -> TyCon "UTCTime"
555 Nat -> TyCon "Natural"
556 Float -> TyCon "Double"
557 Double -> TyCon "Double"
558 Byte -> TyCon "Word8"
559 UInt32 -> TyCon "Word32"
560 UInt64 -> TyCon "Word64"
561 Int32 -> TyCon "Int32"
562 Int64 -> TyCon "Int64"
563 Alt t -> TyCon (unqual (Text.unpack t))
564 RqBody -> TyCon "RequestBody"
565 RsBody -> TyCon "Stream"
566 JSONValue -> TyCon "JSONValue"
568internalLit :: Lit -> Type
569internalLit = \case
570 Text -> TyCon "Text"
571 Bool -> TyCon "Bool"
572 Time -> TyCon "Time'"
573 Date -> TyCon "Date'"
574 DateTime -> TyCon "DateTime'"
575 Nat -> TyApp (TyCon "Textual") (TyCon "Nat")
576 Float -> TyApp (TyCon "Textual") (TyCon "Double")
577 Double -> TyApp (TyCon "Textual") (TyCon "Double")
578 Byte -> TyApp (TyCon "Textual") (TyCon "Word8")
579 UInt32 -> TyApp (TyCon "Textual") (TyCon "Word32")
580 UInt64 -> TyApp (TyCon "Textual") (TyCon "Word64")
581 Int32 -> TyApp (TyCon "Textual") (TyCon "Int32")
582 Int64 -> TyApp (TyCon "Textual") (TyCon "Int64")
583 Alt t -> TyCon (unqual (Text.unpack t))
584 RqBody -> TyCon "RequestBody"
585 RsBody -> TyCon "Stream"
586 JSONValue -> TyCon "JSONValue"
588mapping :: TType -> Exp -> Exp
589mapping t e = infixE e "." (go t)
590 where
591 go = \case
592 TMaybe x@(TList {}) -> var "_Default" : go x
593 TMaybe x -> nest (go x)
594 x -> maybeToList (iso x)
596 nest [] = []
597 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]
599iso :: TType -> Maybe Exp
600iso = \case
601 TList {} -> Just (var "_Coerce")
602 TMap {} -> Just (var "_Coerce")
603 TLit Nat -> Just (var "_Coerce")
604 TLit Time -> Just (var "_Time")
605 TLit Date -> Just (var "_Date")
606 TLit DateTime -> Just (var "_DateTime")
607 TLit Float -> Just (var "_Coerce")
608 TLit Double -> Just (var "_Coerce")
609 TLit Byte -> Just (var "_Coerce")
610 TLit UInt32 -> Just (var "_Coerce")
611 TLit UInt64 -> Just (var "_Coerce")
612 TLit Int32 -> Just (var "_Coerce")
613 TLit Int64 -> Just (var "_Coerce")
614 _ -> Nothing
616require :: TType -> TType
617require (TMaybe t) = t
618require t = t
620strict :: Type -> Type
621strict = TyBang BangedTy . \case
622 t@TyApp{} -> TyParen t
623 t -> t
625sing :: Text -> Type
626sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
628tylist :: [Text] -> Type
629tylist xs = TyCon . UnQual . name . Text.unpack $
630 "'[" <> Text.intercalate ", " xs <> "]"
632tycon :: Global -> Type
633tycon = TyCon . UnQual . dname
635unqual :: String -> QName
636unqual = UnQual . name
638infixE :: Exp -> QOp -> [Exp] -> Exp
639infixE l _ [] = l
640infixE l o (r:rs) = infixE (infixApp l o r) o rs
642str :: Text -> Exp
643str = strE . Text.unpack