git.iko.soy/gogol
on 2835fc2 help sign in
gogol/gen/src/Gen/Syntax.hs
631 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 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 (find, foldl', foldr')
19import Data.Hashable
20import qualified Data.HashMap.Strict as Map
21import Data.List (delete, nub)
22import Data.Maybe
23import Data.Semigroup ((<>))
24import Data.String
25import Data.Text (Text)
26import qualified Data.Text as Text
27import Data.Text.Manipulate
28import Debug.Trace
29import Gen.Orphans
30import Gen.Text
31import Gen.Types
32import Language.Haskell.Exts.Build
33import Language.Haskell.Exts.SrcLoc
34import Language.Haskell.Exts.Syntax hiding (Alt, Int, Lit)
36urlSig :: Name -> Decl
37urlSig n = TypeSig noLoc [n] (TyCon "ServiceConfig")
39urlDecl :: Service a -> Name -> Decl
40urlDecl s n = sfun noLoc n [] (UnGuardedRhs rhs) noBinds
41 where
42 rhs = appFun (var "defaultService")
43 [ app (var "ServiceId") (str (s ^. dId))
44 , str . stripSuffix "/" $ stripPrefix "https://" (s ^. dRootUrl)
45 ]
47scopeSig :: Name -> Decl
48scopeSig n = TypeSig noLoc [n] (TyCon "OAuthScope")
50scopeDecl :: Name -> Text -> Decl
51scopeDecl n s = sfun noLoc n [] (UnGuardedRhs (str s)) noBinds
53 -- type API = :<|> ...
54apiAlias :: Name -> [Name] -> Decl
55apiAlias n ls = TypeDecl noLoc n [] alias
56 where
57 alias = case map (TyCon . UnQual) ls of
58 [] -> unit_tycon
59 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
61verbAlias :: HasDescription a s => a -> Name -> Method Solved -> Decl
62verbAlias d n m = TypeDecl noLoc n [] $ servantOr meta (catMaybes [down, up])
63 where
64 meta = path $ metadataAlias m
65 down = path <$> downloadAlias m
66 up = uploadAlias root m
68 path = flip servantSub root
70 root = subPaths (d ^. dServicePath) ++ requestPath m (_mPath m)
72metadataAlias :: Method Solved -> Type
73metadataAlias m = servantSub (jsonVerb m) (params ++ media)
74 where
75 params = requestQuery m (requestQueryParams m)
76 media = case _mRequest m of
77 Nothing -> []
78 Just b ->
79 [ TyApp (TyApp (TyCon "ReqBody") jsonMedia)
80 (tycon (ref b))
81 ]
83downloadAlias :: Method Solved -> Maybe Type
84downloadAlias m
85 | _mSupportsMediaDownload m = Just download
86 | otherwise = Nothing
87 where
88 download = servantSub (downloadVerb m) (params ++ [altParam])
90 params = requestQuery m . Map.delete "alt" $ requestQueryParams m
92uploadAlias :: [Type] -> Method Solved -> Maybe Type
93uploadAlias sub m
94 | _mSupportsMediaUpload m = Just upload
95 | otherwise = Nothing
96 where
97 upload = servantSub (jsonVerb m) (path ++ params ++ [uploadParam, media])
99 params = requestQuery m (requestQueryParams m)
101 path = case _mMediaUpload m of
102 Nothing -> sub
103 Just u -> requestPath m (_muSimplePath u)
105 media = case _mRequest m of
106 Just b ->
107 TyApp (TyApp (TyApp (TyCon "MultipartRelated") jsonMedia)
108 (tycon (ref b)))
109 (TyCon "RequestBody")
111 Nothing ->
112 TyApp (TyApp (TyCon "ReqBody") streamMedia)
113 (TyCon "RequestBody")
115requestPath :: Method Solved -> Text -> [Type]
116requestPath m = map go . extractPath
117 where
118 go (Left t) = sing t
119 go (Right (l, c)) = case Map.lookup l (_mParameters m) of
120 Nothing -> error $ "Unable to find path parameter " ++ show l
121 Just x -> case c of
122 Nothing | x ^. iRepeated ->
123 TyApp (TyApp (TyCon "Captures")
124 (sing (local l)))
125 (terminalType (_type (_pParam x)))
127 Nothing ->
128 TyApp (TyApp (TyCon "Capture")
129 (sing (local l)))
130 (terminalType (_type (_pParam x)))
132 Just y ->
133 TyApp (TyApp (TyApp (TyCon "CaptureMode")
134 (sing (local l)))
135 (sing y))
136 (terminalType (_type (_pParam x)))
138requestQuery :: Method Solved -> Map Local (Param Solved) -> [Type]
139requestQuery m xs = mapMaybe go $
140 orderParams fst (Map.toList xs) (_mParameterOrder m)
141 where
142 go (k, x) = case _pLocation x of
143 Query | x ^. iRepeated
144 -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t
145 Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t
146 Path -> Nothing
147 where
148 t = terminalType (_type (_pParam x))
149 n = sing (local k)
151requestQueryParams :: Method a -> Map Local (Param a)
152requestQueryParams = Map.filter ((/= Path) . _pLocation) . _mParameters
154servantOr, servantSub :: Type -> [Type] -> Type
155servantOr = foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r)
156servantSub = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r)
158jsonVerb :: Method a -> Type
159jsonVerb m =
160 TyApp (TyApp (httpMethod m) jsonMedia)
161 $ maybe (TyCon "()") (tycon . ref) (_mResponse m)
163downloadVerb :: Method a -> Type
164downloadVerb m =
165 TyApp (TyApp (httpMethod m) streamMedia)
166 (TyCon "Stream")
168httpMethod :: Method a -> Type
169httpMethod = TyCon . unqual . Text.unpack . Text.toTitle . _mHttpMethod
171subPaths :: Text -> [Type]
172subPaths = map sing . filter (not . Text.null) . Text.split (== '/')
174jsonMedia = tylist ["JSON"]
175streamMedia = tylist ["OctetStream"]
177altParam :: Type
178altParam =
179 TyApp (TyApp (TyCon "QueryParam") (sing "alt"))
180 (TyCon "AltMedia")
182uploadParam :: Type
183uploadParam =
184 TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))
185 (TyCon "AltMedia")
187metadataPat = pattern 1
188downloadPat = pattern 2
189uploadPat = pattern 3
191pattern n m = case (n, down, up) of
192 (1, True, True) -> infixOr go (infixOr wild wild)
193 (2, True, True) -> infixOr wild (infixOr go wild)
194 (_, True, True) -> infixOr wild (infixOr wild go)
196 (1, True, _) -> infixOr go wild
197 (_, True, _) -> infixOr wild go
199 (1, _, True) -> infixOr go wild
200 (_, _, True) -> infixOr wild go
202 (_, _, _) -> go
203 where
204 down = _mSupportsMediaDownload m
205 up = _mSupportsMediaUpload m
207 go = pvar "go"
208 wild = PWildCard
210 infixOr l r = PInfixApp l (UnQual (sym ":<|>")) r
212downloadDecl :: Global
213 -> Prefix
214 -> Name
215 -> Name
216 -> [Local]
217 -> Method Solved
218 -> Decl
219downloadDecl n p api url fs m =
220 googleRequestDecl n ty rs [alt] p api url fs m pat prec
221 where
222 ty = TyApp (TyCon "MediaDownload") (tycon n)
223 rs = InsType noLoc (TyApp (TyCon "Rs") ty) (TyCon "Stream")
225 alt = app (var "Just") (var "AltMedia")
226 pat = downloadPat m
228 prec = PApp (UnQual "MediaDownload")
229 [ PRec (UnQual (dname n)) [PFieldWildcard | not (null fs)]
230 ]
232uploadDecl :: Global
233 -> Prefix
234 -> Name
235 -> Name
236 -> [Local]
237 -> Method Solved
238 -> Decl
239uploadDecl n p api url fs m =
240 googleRequestDecl n ty rs extras p api url fs m pat prec
241 where
242 ty = TyApp (TyCon "MediaUpload") (tycon n)
243 rs = InsType noLoc (TyApp (TyCon "Rs") ty) $
244 maybe unit_tycon (tycon . ref) (_mResponse m)
246 extras = maybeToList alt ++ [upl] ++ payload ++ [var media]
247 where
248 upl = app (var "Just") (var "AltMedia")
249 alt = app (var "Just") . var . name . Text.unpack . alternate <$>
250 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
252 payload
253 | isJust (_mRequest m) = [var (fname p "payload")]
254 | otherwise = []
256 pat = uploadPat m
258 prec = PApp (UnQual "MediaUpload")
259 [ PRec (UnQual (dname n)) [PFieldWildcard | not (null fs)]
260 , PVar media
261 ]
263 media = name "body"
265requestDecl :: Global
266 -> Prefix
267 -> Name
268 -> Name
269 -> [Local]
270 -> Method Solved
271 -> Decl
272requestDecl n p api url fs m =
273 googleRequestDecl n (tycon n) rs extras p api url fs m pat prec
274 where
275 rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
276 maybe unit_tycon (tycon . ref) (_mResponse m)
278 extras = catMaybes [alt, payload]
279 where
280 alt = app (var "Just") . var . name . Text.unpack . alternate <$>
281 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
283 payload
284 | isJust (_mRequest m) = Just $ var (fname p "payload")
285 | otherwise = Nothing
287 pat = metadataPat m
289 prec = PRec (UnQual (dname n)) [PFieldWildcard | not (null fs)]
291googleRequestDecl :: Global
292 -> Type
293 -> InstDecl
294 -> [Exp]
295 -> Prefix
296 -> Name
297 -> Name
298 -> [Local]
299 -> Method Solved
300 -> Pat
301 -> Pat
302 -> Decl
303googleRequestDecl g n assoc extras p api url fields m pat prec =
304 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n]
305 [ assoc
306 , request
307 ]
308 where
309 request = InsDecl (FunBind [match])
310 where
311 match = Match noLoc (name "requestClient") [prec] Nothing rhs (Just decls)
313 decls = BDecls
314 [ patBind noLoc pat $
315 appFun (var "buildClient") $
316 [ ExpTypeSig noLoc (var "Proxy") $
317 TyApp (TyCon "Proxy") (TyCon (UnQual api))
318 , var "mempty"
319 ]
320 ]
322 rhs = UnGuardedRhs . appFun (var "go") $ map go fs ++ extras ++ [var url]
323 where
324 go l = case Map.lookup l ps of
325 Just p | _pLocation p == Query
326 , defaulted p
327 , p ^. iRepeated -> v l
329 Just p | _pLocation p == Query
330 , not (required p)
331 , p ^. iRepeated -> infixApp (v l) "^." (var "_Default")
333 Just p | _pLocation p == Query
334 , not (p ^. iRepeated)
335 , parameter p || defaulted p -> app (var "Just") (v l)
337 _ -> v l
339 ps = _mParameters m
340 v = var . fname p
342 fs = delete "alt"
343 . orderParams id (Map.keys (_mParameters m))
344 . nub
345 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m
347jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
348jsonDecls g p (Map.toList -> rs) = [from, to]
349 where
350 from = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
351 [ funD "parseJSON" $
352 app (app (var "withObject") (dstr g)) $
353 lamE noLoc [pvar "o"] $
354 ctorE g (map decode rs)
355 ]
357 decode (l, s)
358 | _additional s = app (var "parseJSONObject") (var "o")
359 | Just x <- def s = defJS l x
360 | required s = reqJS l
361 | monoid s = defJS l (var "mempty")
362 | otherwise = optJS l
364 to = case rs of
365 [(k, v)] | _additional v ->
366 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
367 [ funD "toJSON" $
368 infixApp (var "toJSON") "." (var (fname p k))
369 ]
371 _ ->
372 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
373 [ wildcardD "toJSON" g omit none (map encode rs)
374 ]
376 omit = app (var "object")
377 . app (var "catMaybes")
378 . listE
380 none = var "emptyObject"
382 encode (l, s)
383 | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a
384 | otherwise = app (var "Just") (infixApp n ".=" a)
385 where
386 n = fstr l
387 a = var (fname p l)
388 o = var ".="
390wildcardD :: String
391 -> Global
392 -> ([Exp] -> Exp)
393 -> Exp
394 -> [Exp]
395 -> InstDecl
396wildcardD f n enc x = \case
397 [] -> constD f x
398 xs -> InsDecl (FunBind [match prec xs])
399 where
400 match p es =
401 Match noLoc (name f) [p] Nothing (UnGuardedRhs (enc es)) noBinds
403 prec = PRec (UnQual (dname n)) [PFieldWildcard]
405defJS :: Local -> Exp -> Exp
406defJS n x = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!=" x
408reqJS :: Local -> Exp
409reqJS = infixApp (var "o") ".:" . fstr
411optJS :: Local -> Exp
412optJS = infixApp (var "o") ".:?" . fstr
414funD :: String -> Exp -> InstDecl
415funD f = InsDecl . patBind noLoc (pvar (name f))
417constD :: String -> Exp -> InstDecl
418constD f x = InsDecl $
419 sfun noLoc (name f) [] (UnGuardedRhs (app (var "const") x)) noBinds
421ctorE :: Global -> [Exp] -> Exp
422ctorE n = seqE (var (dname n)) . map paren
424seqE :: Exp -> [Exp] -> Exp
425seqE l [] = app (var "pure") l
426seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
428objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl
429objDecl n p ds rs = DataDecl noLoc arity [] d [] [conDecl d p rs] (der ds)
430 where
431 d = dname n
433 arity | Map.size rs == 1 = NewType
434 | otherwise = DataType
436 der = map ((,[]) . unqual . drop 1 . show)
438conDecl :: Name -> Prefix -> Map Local Solved -> QualConDecl
439conDecl n p rs = QualConDecl noLoc [] [] body
440 where
441 body = case Map.toList rs of
442 [] -> ConDecl n []
443 [x] -> RecDecl n [field internalType x]
444 xs -> RecDecl n (map (field (strict . internalType)) xs)
446 field f (l, v) = ([fname p l], f (_type v))
448ctorSig :: Global -> Map Local Solved -> Decl
449ctorSig n rs = TypeSig noLoc [cname n] ts
450 where
451 ts = foldr' TyFun (TyCon (UnQual (dname n))) ps
452 ps = parameters (Map.elems rs)
454ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl
455ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
456 where
457 c = cname n
458 d = dname n
460 rhs | Map.null rs = var d
461 | otherwise = RecConstr (UnQual d) $
462 map (uncurry (fieldUpdate p)) (Map.toList rs)
464 ps = map (pname p) . Map.keys $ Map.filter parameter rs
466fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate
467fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
468 where
469 rhs | Just x <- def s, s ^. iRepeated = listE [x]
470 | Just x <- def s = x
471 | Just x <- iso (_type s) = infixApp x "#" v
472 | parameter s = v
473 | otherwise = var (name "Nothing")
475 v = var (pname p l)
477lensSig :: Global -> Prefix -> Local -> Solved -> Decl
478lensSig n p l s = TypeSig noLoc [lname p l] $
479 TyApp (TyApp (TyCon "Lens'") (tycon n))
480 (externalType (_type s))
482lensDecl :: Prefix -> Local -> Solved -> Decl
483lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
484 where
485 f = fname p l
486 t = _type s
488 rhs = mapping t $
489 app (app (var "lens") (var f))
490 (paren (lamE noLoc [pvar "s", pvar "a"]
491 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
493parameters :: [Solved] -> [Type]
494parameters = map (externalType . _type) . filter parameter
496def :: Solved -> Maybe Exp
497def s
498 | Just x <- s ^. iDefault = Just (go x (_prefix s) (_schema s))
499 | otherwise = Nothing
500 where
501 go x p = \case
502 SEnm {} -> var (bname p x)
503 SLit _ Bool -> lit (upperHead x)
504 SLit _ Text -> str x
505 SLit {} -> lit x
506 e -> error $ "Unsupported default value: " ++ show e
508 lit = var . name . Text.unpack
510terminalType :: TType -> Type
511terminalType = internalType . go
512 where
513 go (TMaybe x) = go x
514 go (TList x) = go x
515 go x = x
517externalType :: TType -> Type
518externalType = \case
519 TType r -> tycon r
520 TMaybe t@TList {} -> externalType t
521 TMaybe t -> TyApp (TyCon "Maybe") (externalType t)
522 TList t -> TyList (externalType t)
523 TLit l -> externalLit l
524 TMap k v ->
525 TyApp (TyApp (TyCon "HashMap") (externalType k)) (externalType (require v))
527internalType :: TType -> Type
528internalType = \case
529 TType r -> tycon r
530 TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
531 TList t -> TyList (internalType t)
532 TLit l -> internalLit l
533 TMap k v ->
534 TyApp (TyApp (TyCon "HashMap") (internalType k)) (internalType (require v))
536externalLit :: Lit -> Type
537externalLit = \case
538 Text -> TyCon "Text"
539 Bool -> TyCon "Bool"
540 Time -> TyCon "TimeOfDay"
541 Date -> TyCon "Day"
542 DateTime -> TyCon "UTCTime"
543 Nat -> TyCon "Natural"
544 Float -> TyCon "Double"
545 Double -> TyCon "Double"
546 Byte -> TyCon "Word8"
547 UInt32 -> TyCon "Word32"
548 UInt64 -> TyCon "Word64"
549 Int32 -> TyCon "Int32"
550 Int64 -> TyCon "Int64"
551 Alt t -> TyCon (unqual (Text.unpack t))
552 RqBody -> TyCon "RequestBody"
553 RsBody -> TyCon "Stream"
554 JSONValue -> TyCon "JSONValue"
556internalLit :: Lit -> Type
557internalLit = \case
558 Text -> TyCon "Text"
559 Bool -> TyCon "Bool"
560 Time -> TyCon "Time'"
561 Date -> TyCon "Date'"
562 DateTime -> TyCon "DateTime'"
563 Nat -> TyApp (TyCon "Textual") (TyCon "Nat")
564 Float -> TyApp (TyCon "Textual") (TyCon "Double")
565 Double -> TyApp (TyCon "Textual") (TyCon "Double")
566 Byte -> TyApp (TyCon "Textual") (TyCon "Word8")
567 UInt32 -> TyApp (TyCon "Textual") (TyCon "Word32")
568 UInt64 -> TyApp (TyCon "Textual") (TyCon "Word64")
569 Int32 -> TyApp (TyCon "Textual") (TyCon "Int32")
570 Int64 -> TyApp (TyCon "Textual") (TyCon "Int64")
571 Alt t -> TyCon (unqual (Text.unpack t))
572 RqBody -> TyCon "RequestBody"
573 RsBody -> TyCon "Stream"
574 JSONValue -> TyCon "JSONValue"
576mapping :: TType -> Exp -> Exp
577mapping t e = infixE e "." (go t)
578 where
579 go = \case
580 TMaybe x@(TList {}) -> var "_Default" : go x
581 TMaybe x -> nest (go x)
582 x -> maybeToList (iso x)
584 nest [] = []
585 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]
587iso :: TType -> Maybe Exp
588iso = \case
589 TList {} -> Just (var "_Coerce")
590 TMap {} -> Just (var "_Coerce")
591 TLit Nat -> Just (var "_Coerce")
592 TLit Time -> Just (var "_Time")
593 TLit Date -> Just (var "_Date")
594 TLit DateTime -> Just (var "_DateTime")
595 TLit Float -> Just (var "_Coerce")
596 TLit Double -> Just (var "_Coerce")
597 TLit Byte -> Just (var "_Coerce")
598 TLit UInt32 -> Just (var "_Coerce")
599 TLit UInt64 -> Just (var "_Coerce")
600 TLit Int32 -> Just (var "_Coerce")
601 TLit Int64 -> Just (var "_Coerce")
602 _ -> Nothing
604require :: TType -> TType
605require (TMaybe t) = t
606require t = t
608strict :: Type -> Type
609strict = TyBang BangedTy . \case
610 t@TyApp{} -> TyParen t
611 t -> t
613sing :: Text -> Type
614sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
616tylist :: [Text] -> Type
617tylist xs = TyCon . UnQual . name . Text.unpack $
618 "'[" <> Text.intercalate ", " xs <> "]"
620tycon :: Global -> Type
621tycon = TyCon . UnQual . dname
623unqual :: String -> QName
624unqual = UnQual . name
626infixE :: Exp -> QOp -> [Exp] -> Exp
627infixE l _ [] = l
628infixE l o (r:rs) = infixE (infixApp l o r) o rs
630str :: Text -> Exp
631str = strE . Text.unpack