git.iko.soy/gogol
on eaec028 help sign in
gogol/gen/src/Gen/Syntax.hs
659 lines 21 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 ++ [downloadParam])
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 ++ 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 [ multipartParam
110 , TyApp (TyApp (TyCon "MultipartRelated") jsonMedia)
111 (tycon (ref b))
112 ]
114 Nothing ->
115 [ mediaParam
116 , TyCon "AltMedia"
117 ]
119requestPath :: Method Solved -> Text -> [Type]
120requestPath m = map go . extractPath
121 where
122 go (Left t) = sing t
123 go (Right (l, c)) = case Map.lookup l (_mParameters m) of
124 Nothing -> error $ "Unable to find path parameter " ++ show l
125 Just x -> case c of
126 Nothing | x ^. iRepeated ->
127 TyApp (TyApp (TyCon "Captures")
128 (sing (local l)))
129 (terminalType (_type (_pParam x)))
131 Nothing ->
132 TyApp (TyApp (TyCon "Capture")
133 (sing (local l)))
134 (terminalType (_type (_pParam x)))
136 Just y ->
137 TyApp (TyApp (TyApp (TyCon "CaptureMode")
138 (sing (local l)))
139 (sing y))
140 (terminalType (_type (_pParam x)))
142requestQuery :: Method Solved -> Map Local (Param Solved) -> [Type]
143requestQuery m xs = mapMaybe go $
144 orderParams fst (Map.toList xs) (_mParameterOrder m)
145 where
146 go (k, x) = case _pLocation x of
147 Query | x ^. iRepeated
148 -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t
149 Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t
150 Path -> Nothing
151 where
152 t = terminalType (_type (_pParam x))
153 n = sing (local k)
155requestQueryParams :: Method a -> Map Local (Param a)
156requestQueryParams = Map.filter ((/= Path) . _pLocation) . _mParameters
158servantOr, servantSub :: Type -> [Type] -> Type
159servantOr = foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r)
160servantSub = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r)
162jsonVerb :: Method a -> Type
163jsonVerb m =
164 TyApp (TyApp (httpMethod m) jsonMedia)
165 $ maybe (TyCon "()") (tycon . ref) (_mResponse m)
167downloadVerb :: Method a -> Type
168downloadVerb m =
169 TyApp (TyApp (httpMethod m) streamMedia)
170 (TyCon "Stream")
172httpMethod :: Method a -> Type
173httpMethod = TyCon . unqual . Text.unpack . Text.toTitle . _mHttpMethod
175subPaths :: Text -> [Type]
176subPaths = map sing . filter (not . Text.null) . Text.split (== '/')
178jsonMedia, streamMedia :: Type
179jsonMedia = tylist ["JSON"]
180streamMedia = tylist ["OctetStream"]
182downloadParam :: Type
183downloadParam =
184 TyApp (TyApp (TyCon "QueryParam") (sing "alt"))
185 (TyCon "AltMedia")
187mediaParam :: Type
188mediaParam =
189 TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))
190 (TyCon "AltMedia")
192multipartParam :: Type
193multipartParam =
194 TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))
195 (TyCon "Multipart")
197metadataPat, downloadPat, uploadPat :: Method a -> Pat
198metadataPat = pattern 1
199downloadPat = pattern 2
200uploadPat = pattern 3
202pattern :: Integer -> Method a -> Pat
203pattern n m = case (n, down, up) of
204 (1, True, True) -> infixOr go (infixOr wild wild)
205 (2, True, True) -> infixOr wild (infixOr go wild)
206 (_, True, True) -> infixOr wild (infixOr wild go)
208 (1, True, _) -> infixOr go wild
209 (_, True, _) -> infixOr wild go
211 (1, _, True) -> infixOr go wild
212 (_, _, True) -> infixOr wild go
214 (_, _, _) -> go
215 where
216 down = _mSupportsMediaDownload m
217 up = _mSupportsMediaUpload m
219 go = pvar "go"
220 wild = PWildCard
222 infixOr l r = PInfixApp l (UnQual (sym ":<|>")) r
224downloadDecl :: Global
225 -> Prefix
226 -> Name
227 -> Name
228 -> [Local]
229 -> Method Solved
230 -> Decl
231downloadDecl n pre api url fs m =
232 googleRequestDecl ty [rs, ss] [alt] pre api url m pat prec
233 where
234 ty = TyApp (TyCon "MediaDownload") (tycon n)
236 rs = InsType noLoc (TyApp (TyCon "Rs") ty) (TyCon "Stream")
238 ss = InsType noLoc (TyApp (TyCon "Scopes") ty) $
239 TyApp (TyCon "Scopes") (tycon n)
241 alt = app (var "Just") (var "AltMedia")
242 pat = downloadPat m
244 prec = PApp (UnQual "MediaDownload")
245 [ PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]
246 ]
248uploadDecl :: Global
249 -> Prefix
250 -> Name
251 -> Name
252 -> [Local]
253 -> Method Solved
254 -> Decl
255uploadDecl n pre api url fs m =
256 googleRequestDecl ty [rs, ss] extras pre api url m pat prec
257 where
258 ty = TyApp (TyCon "MediaUpload") (tycon n)
260 rs = InsType noLoc (TyApp (TyCon "Rs") ty) $
261 maybe unit_tycon (tycon . ref) (_mResponse m)
263 ss = InsType noLoc (TyApp (TyCon "Scopes") ty) $
264 TyApp (TyCon "Scopes") (tycon n)
266 extras = maybeToList alt ++ [upl] ++ payload ++ [var media]
267 where
268 upl = app (var "Just") $
269 if isJust (_mRequest m)
270 then var "Multipart"
271 else var "AltMedia"
273 alt = app (var "Just") . var . name . Text.unpack . alternate <$>
274 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
276 payload
277 | isJust (_mRequest m) = [var (fname pre "payload")]
278 | otherwise = []
280 pat = uploadPat m
282 prec = PApp (UnQual "MediaUpload")
283 [ PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]
284 , PVar media
285 ]
287 media = name "body"
289requestDecl :: Global
290 -> Prefix
291 -> Name
292 -> Name
293 -> [Local]
294 -> Method Solved
295 -> Decl
296requestDecl n pre api url fs m =
297 googleRequestDecl (tycon n) [rs, ss] extras pre api url m pat prec
298 where
299 rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
300 maybe unit_tycon (tycon . ref) (_mResponse m)
302 ss = InsType noLoc (TyApp (TyCon "Scopes") (tycon n)) $
303 TyPromoted $
304 PromotedList True $
305 map (TyPromoted . PromotedString . Text.unpack) (_mScopes m)
307 extras = catMaybes [alt, payload]
308 where
309 alt = app (var "Just") . var . name . Text.unpack . alternate <$>
310 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
312 payload
313 | isJust (_mRequest m) = Just $ var (fname pre "payload")
314 | otherwise = Nothing
316 pat = metadataPat m
318 prec = PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]
320googleRequestDecl :: Type
321 -> [InstDecl]
322 -> [Exp]
323 -> Prefix
324 -> Name
325 -> Name
326 -> Method Solved
327 -> Pat
328 -> Pat
329 -> Decl
330googleRequestDecl n assoc extras pre api url m pat prec =
331 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n] (assoc ++ [request])
332 where
333 request = InsDecl (FunBind [match])
335 match = Match noLoc (name "requestClient") [prec] Nothing rhs (Just decls)
337 decls = BDecls
338 [ patBind noLoc pat $
339 appFun (var "buildClient") $
340 [ ExpTypeSig noLoc (var "Proxy") $
341 TyApp (TyCon "Proxy") (TyCon (UnQual api))
342 , var "mempty"
343 ]
344 ]
346 rhs = UnGuardedRhs . appFun (var "go") $ map go fs ++ extras ++ [var url]
347 where
348 go l = case Map.lookup l ps of
349 Just p | _pLocation p == Query
350 , defaulted p
351 , p ^. iRepeated -> v l
353 Just p | _pLocation p == Query
354 , not (required p)
355 , p ^. iRepeated -> infixApp (v l) "^." (var "_Default")
357 Just p | _pLocation p == Query
358 , not (p ^. iRepeated)
359 , parameter p || defaulted p -> app (var "Just") (v l)
361 _ -> v l
363 ps = _mParameters m
364 v = var . fname pre
366 fs = delete "alt"
367 . orderParams id (Map.keys (_mParameters m))
368 . nub
369 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m
371jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
372jsonDecls g p (Map.toList -> rs) = [from', to']
373 where
374 from' = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
375 [ funD "parseJSON" $
376 app (app (var "withObject") (dstr g)) $
377 lamE noLoc [pvar "o"] $
378 ctorE g (map decode rs)
379 ]
381 decode (l, s)
382 | _additional s = app (var "parseJSONObject") (var "o")
383 | Just x <- def s = defJS l x
384 | required s = reqJS l
385 | monoid s = defJS l (var "mempty")
386 | otherwise = optJS l
388 to' = case rs of
389 [(k, v)] | _additional v ->
390 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
391 [ funD "toJSON" $
392 infixApp (var "toJSON") "." (var (fname p k))
393 ]
395 _ ->
396 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
397 [ wildcardD "toJSON" g omit emptyObj (map encode rs)
398 ]
400 omit = app (var "object")
401 . app (var "catMaybes")
402 . listE
404 emptyObj = var "emptyObject"
406 encode (l, s)
407 | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a
408 | otherwise = app (var "Just") (infixApp n ".=" a)
409 where
410 n = fstr l
411 a = var (fname p l)
412 o = var ".="
414wildcardD :: String
415 -> Global
416 -> ([Exp] -> Exp)
417 -> Exp
418 -> [Exp]
419 -> InstDecl
420wildcardD f n enc x = \case
421 [] -> constD f x
422 xs -> InsDecl (FunBind [match prec xs])
423 where
424 match p es =
425 Match noLoc (name f) [p] Nothing (UnGuardedRhs (enc es)) noBinds
427 prec = PRec (UnQual (dname' n)) [PFieldWildcard]
429defJS :: Local -> Exp -> Exp
430defJS n x = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!=" x
432reqJS :: Local -> Exp
433reqJS = infixApp (var "o") ".:" . fstr
435optJS :: Local -> Exp
436optJS = infixApp (var "o") ".:?" . fstr
438funD :: String -> Exp -> InstDecl
439funD f = InsDecl . patBind noLoc (pvar (name f))
441constD :: String -> Exp -> InstDecl
442constD f x = InsDecl $
443 sfun noLoc (name f) [] (UnGuardedRhs (app (var "const") x)) noBinds
445ctorE :: Global -> [Exp] -> Exp
446ctorE n = seqE (var (dname' n)) . map paren
448seqE :: Exp -> [Exp] -> Exp
449seqE l [] = app (var "pure") l
450seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
452objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl
453objDecl n p ds rs =
454 DataDecl noLoc arity [] (dname n) [] [conDecl (dname' n) p rs] (der ds)
455 where
456 arity | Map.size rs == 1 = NewType
457 | otherwise = DataType
459 der = map ((,[]) . unqual . drop 1 . show)
461conDecl :: Name -> Prefix -> Map Local Solved -> QualConDecl
462conDecl n p rs = QualConDecl noLoc [] [] body
463 where
464 body = case Map.toList rs of
465 [] -> ConDecl n []
466 [x] -> RecDecl n [field internalType x]
467 xs -> RecDecl n (map (field (strict . internalType)) xs)
469 field f (l, v) = ([fname p l], f (_type v))
471ctorSig :: Global -> Map Local Solved -> Decl
472ctorSig n rs = TypeSig noLoc [cname n] ts
473 where
474 ts = foldr' TyFun (TyCon (UnQual (dname n))) ps
475 ps = parameters (Map.elems rs)
477ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl
478ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
479 where
480 c = cname n
481 d = dname' n
483 rhs | Map.null rs = var d
484 | otherwise = RecConstr (UnQual d) $
485 map (uncurry (fieldUpdate p)) (Map.toList rs)
487 ps = map (pname p) . Map.keys $ Map.filter parameter rs
489fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate
490fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
491 where
492 rhs | Just x <- def s, s ^. iRepeated = listE [x]
493 | Just x <- def s = x
494 | Just x <- iso (_type s) = infixApp x "#" v
495 | parameter s = v
496 | otherwise = var (name "Nothing")
498 v = var (pname p l)
500lensSig :: Global -> Prefix -> Local -> Solved -> Decl
501lensSig n p l s = TypeSig noLoc [lname p l] $
502 TyApp (TyApp (TyCon "Lens'") (tycon n))
503 (externalType (_type s))
505lensDecl :: Prefix -> Local -> Solved -> Decl
506lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
507 where
508 f = fname p l
509 t = _type s
511 rhs = mapping t $
512 app (app (var "lens") (var f))
513 (paren (lamE noLoc [pvar "s", pvar "a"]
514 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
516parameters :: [Solved] -> [Type]
517parameters = map (externalType . _type) . filter parameter
519def :: Solved -> Maybe Exp
520def s
521 | Just x <- s ^. iDefault = Just (go x (_prefix s) (_schema s))
522 | otherwise = Nothing
523 where
524 go x p = \case
525 SEnm {} -> var (bname p x)
526 SLit _ Bool -> lit (upperHead x)
527 SLit _ Text -> str x
528 SLit {} -> lit x
529 e -> error $ "Unsupported default value: " ++ show e
531 lit = var . name . Text.unpack
533terminalType :: TType -> Type
534terminalType = internalType . go
535 where
536 go (TMaybe x) = go x
537 go (TList x) = go x
538 go x = x
540externalType :: TType -> Type
541externalType = \case
542 TType r -> tycon r
543 TMaybe t@TList {} -> externalType t
544 TMaybe t -> TyApp (TyCon "Maybe") (externalType t)
545 TList t -> TyList (externalType t)
546 TLit l -> externalLit l
547 TMap k v ->
548 TyApp (TyApp (TyCon "HashMap") (externalType k)) (externalType (require v))
550internalType :: TType -> Type
551internalType = \case
552 TType r -> tycon r
553 TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
554 TList t -> TyList (internalType t)
555 TLit l -> internalLit l
556 TMap k v ->
557 TyApp (TyApp (TyCon "HashMap") (internalType k)) (internalType (require v))
559externalLit :: Lit -> Type
560externalLit = \case
561 Text -> TyCon "Text"
562 Bool -> TyCon "Bool"
563 Time -> TyCon "TimeOfDay"
564 Date -> TyCon "Day"
565 DateTime -> TyCon "UTCTime"
566 Nat -> TyCon "Natural"
567 Float -> TyCon "Double"
568 Double -> TyCon "Double"
569 Byte -> TyCon "ByteString"
570 UInt32 -> TyCon "Word32"
571 UInt64 -> TyCon "Word64"
572 Int32 -> TyCon "Int32"
573 Int64 -> TyCon "Int64"
574 Alt t -> TyCon (unqual (Text.unpack t))
575 RqBody -> TyCon "RequestBody"
576 RsBody -> TyCon "Stream"
577 JSONValue -> TyCon "JSONValue"
578 FieldMask -> TyCon "FieldMask"
579 Duration -> TyCon "Scientific"
581internalLit :: Lit -> Type
582internalLit = \case
583 Text -> TyCon "Text"
584 Bool -> TyCon "Bool"
585 Time -> TyCon "Time'"
586 Date -> TyCon "Date'"
587 DateTime -> TyCon "DateTime'"
588 Nat -> TyApp (TyCon "Textual") (TyCon "Nat")
589 Float -> TyApp (TyCon "Textual") (TyCon "Double")
590 Double -> TyApp (TyCon "Textual") (TyCon "Double")
591 Byte -> TyCon "Base64"
592 UInt32 -> TyApp (TyCon "Textual") (TyCon "Word32")
593 UInt64 -> TyApp (TyCon "Textual") (TyCon "Word64")
594 Int32 -> TyApp (TyCon "Textual") (TyCon "Int32")
595 Int64 -> TyApp (TyCon "Textual") (TyCon "Int64")
596 Alt t -> TyCon (unqual (Text.unpack t))
597 RqBody -> TyCon "RequestBody"
598 RsBody -> TyCon "Stream"
599 JSONValue -> TyCon "JSONValue"
600 FieldMask -> TyCon "FieldMask"
601 Duration -> TyCon "Duration"
603mapping :: TType -> Exp -> Exp
604mapping t e = infixE e "." (go t)
605 where
606 go = \case
607 TMaybe x@(TList {}) -> var "_Default" : go x
608 TMaybe x -> nest (go x)
609 x -> maybeToList (iso x)
611 nest [] = []
612 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]
614iso :: TType -> Maybe Exp
615iso = \case
616 TList {} -> Just (var "_Coerce")
617 TMap {} -> Just (var "_Coerce")
618 TLit Nat -> Just (var "_Coerce")
619 TLit Time -> Just (var "_Time")
620 TLit Date -> Just (var "_Date")
621 TLit DateTime -> Just (var "_DateTime")
622 TLit Duration -> Just (var "_Duration")
623 TLit Float -> Just (var "_Coerce")
624 TLit Double -> Just (var "_Coerce")
625 TLit Byte -> Just (var "_Base64")
626 TLit UInt32 -> Just (var "_Coerce")
627 TLit UInt64 -> Just (var "_Coerce")
628 TLit Int32 -> Just (var "_Coerce")
629 TLit Int64 -> Just (var "_Coerce")
630 _ -> Nothing
632require :: TType -> TType
633require (TMaybe t) = t
634require t = t
636strict :: Type -> Type
637strict = TyBang BangedTy . \case
638 t@TyApp{} -> TyParen t
639 t -> t
641sing :: Text -> Type
642sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
644tylist :: [Text] -> Type
645tylist xs = TyCon . UnQual . name . Text.unpack $
646 "'[" <> Text.intercalate ", " xs <> "]"
648tycon :: Global -> Type
649tycon = TyCon . UnQual . dname
651unqual :: String -> QName
652unqual = UnQual . name
654infixE :: Exp -> QOp -> [Exp] -> Exp
655infixE l _ [] = l
656infixE l o (r:rs) = infixE (infixApp l o r) o rs
658str :: Text -> Exp
659str = strE . Text.unpack