git.iko.soy/gogol
on bd11cd3 help sign in
gogol/gen/src/Gen/Syntax.hs
526 lines 17 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 "Service")
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 , str (s ^. dServicePath)
46 ]
48scopeSig :: Name -> Decl
49scopeSig n = TypeSig noLoc [n] (TyCon "OAuthScope")
51scopeDecl :: Name -> Text -> Decl
52scopeDecl n s = sfun noLoc n [] (UnGuardedRhs (str s)) noBinds
54 -- type API = :<|> ...
55apiAlias :: Name -> [Name] -> Decl
56apiAlias n ls = TypeDecl noLoc n [] alias
57 where
58 alias = case map (TyCon . UnQual) ls of
59 [] -> unit_tycon
60 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
62-- type Method = :> ...
63verbAlias :: Name -> Method Solved -> Decl
64verbAlias n m
65 | _mSupportsMediaDownload m = TypeDecl noLoc n [] download
66 | otherwise = TypeDecl noLoc n [] rest
67 where
68 rest = alias verb (path ++ qry params ++ media)
69 download = TyInfix rest (UnQual (sym ":<|>")) $
70 alias (TyApp (TyApp meth octet) (TyCon "Stream"))
71 (path ++ qry (Map.delete "alt" (_mParameters m)) ++ [alt] ++ media)
73 alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r)
75 path :: [Type]
76 path = map match $ extractPath (_mPath m)
77 where
78 match (Left t) = sing t
79 match (Right (l, c)) =
80 case Map.lookup l (_mParameters m) of
81 Nothing -> error $ "Unable to find path parameter " ++ show l
82 Just x ->
83 case c of
84 Nothing | x ^. iRepeated ->
85 TyApp (TyApp (TyCon "Captures")
86 (sing (local l)))
87 (terminalType (_type (_pParam x)))
89 Nothing ->
90 TyApp (TyApp (TyCon "Capture")
91 (sing (local l)))
92 (terminalType (_type (_pParam x)))
94 Just y ->
95 TyApp (TyApp (TyApp (TyCon "CaptureMode")
96 (sing (local l)))
97 (sing y))
98 (terminalType (_type (_pParam x)))
101 qry xs = mapMaybe f $ orderParams fst (Map.toList xs) (_mParameterOrder m)
102 where
103 f (k, x) =
104 let t = terminalType (_type (_pParam x))
105 n = sing (local k)
106 in case _pLocation x of
107 Query | x ^. iRepeated
108 -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t
109 Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t
110 Path -> Nothing
112 media :: [Type]
113 media | Just b <- _mRequest m
114 , _mSupportsMediaUpload m =
115 [TyApp (TyApp (TyApp (TyCon "MultipartRelated") json)
116 (tycon (ref b)))
117 (TyCon "Body")]
119 | Just b <- _mRequest m =
120 [TyApp (TyApp (TyCon "ReqBody") json) (tycon (ref b))]
122 | _mSupportsMediaUpload m =
123 [TyApp (TyApp (TyCon "ReqBody") octet) (TyCon "Body")]
125 | otherwise = []
127 verb = TyApp (TyApp meth json) $
128 maybe (TyCon "()") (tycon . ref) (_mResponse m)
130 meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mHttpMethod m)
132 octet = tylist ["OctetStream"]
133 json = tylist ["JSON"]
135 alt = TyApp (TyApp (TyCon "QueryParam") (sing "alt")) (TyCon "AltMedia")
137 params = Map.filter ((/= Path) . _pLocation) (_mParameters m)
139downloadDecl :: Global
140 -> Prefix
141 -> Name
142 -> Name
143 -> [Local]
144 -> Method Solved
145 -> Decl
146downloadDecl n p api url fs m =
147 googleRequestDecl n ty rs alt p api url fs m pat prec
148 where
149 ty = TyApp (TyCon "Download") (tycon n)
150 rs = InsType noLoc (TyApp (TyCon "Rs") ty) (TyCon "Stream")
152 alt = Just (var "AltMedia")
154 pat | _mSupportsMediaDownload m = PInfixApp PWildCard (UnQual (sym ":<|>")) (pvar "go")
155 | otherwise = pvar "go"
157 prec = PApp (UnQual "Download")
158 [ PRec (UnQual (dname n)) [PFieldWildcard | not (null fs)]
159 ]
161requestDecl :: Global
162 -> Prefix
163 -> Name
164 -> Name
165 -> [Local]
166 -> Method Solved
167 -> Decl
168requestDecl n p api url fs m =
169 googleRequestDecl n (tycon n) rs alt p api url fs m pat prec
170 where
171 rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
172 maybe unit_tycon (tycon . ref) (_mResponse m)
174 alt = var . name . Text.unpack . alternate <$>
175 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
177 pat | _mSupportsMediaDownload m = PInfixApp (pvar "go") (UnQual (sym ":<|>")) PWildCard
178 | otherwise = pvar "go"
180 prec = PRec (UnQual (dname n)) [PFieldWildcard | not (null fs)]
182googleRequestDecl :: Global
183 -> Type
184 -> InstDecl
185 -> Maybe Exp
186 -> Prefix
187 -> Name
188 -> Name
189 -> [Local]
190 -> Method Solved
191 -> Pat
192 -> Pat
193 -> Decl
194googleRequestDecl g n assoc alt p api url fields m pat prec =
195 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n]
196 [ assoc
197 , request
198 ]
199 where
200 request = InsDecl (FunBind [match])
201 where
202 match = Match noLoc (name "requestClient") [prec] Nothing rhs decls
204 decls = BDecls
205 [ patBind noLoc pat $
206 appFun (var "buildClient") $
207 [ ExpTypeSig noLoc (var "Proxy") $
208 TyApp (TyCon "Proxy") (TyCon (UnQual api))
209 , var "mempty"
210 ]
211 ]
213 rhs = UnGuardedRhs . appFun (var "go") $ map go fs'
214 ++ maybeToList (app (var "Just") <$> alt)
215 ++ maybeToList (go <$> rq)
216 ++ maybeToList (go <$> pay)
217 ++ [var url]
218 where
219 go l = case Map.lookup l ps of
220 Just p | _pLocation p == Query
221 , defaulted p
222 , p ^. iRepeated -> v l
224 Just p | _pLocation p == Query
225 , not (required p)
226 , p ^. iRepeated -> infixApp (v l) "^." (var "_Default")
228 Just p | _pLocation p == Query
229 , not (p ^. iRepeated)
230 , parameter p || defaulted p -> app (var "Just") (v l)
232 _ -> v l
234 ps = _mParameters m
235 v = var . fname p
237 (fs', rq) | Just _ <- _mRequest m = (delete "payload" fs, Just "payload")
238 | otherwise = (fs, Nothing)
240 pay | _mSupportsMediaUpload m = Just "media"
241 | otherwise = Nothing
243 fs = delete "alt"
244 . orderParams id (Map.keys (_mParameters m))
245 . nub
246 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m
248jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
249jsonDecls g p (Map.toList -> rs) = [from, to]
250 where
251 from = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
252 [ funD "parseJSON" $
253 app (app (var "withObject") (dstr g)) $
254 lamE noLoc [pvar "o"] $
255 ctorE g (map decode rs)
256 ]
258 decode (l, s)
259 | _additional s = app (var "parseJSONObject") (var "o")
260 | Just x <- def s = defJS l x
261 | required s = reqJS l
262 | monoid s = defJS l (var "mempty")
263 | otherwise = optJS l
265 to = case rs of
266 [(k, v)] | _additional v ->
267 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
268 [ funD "toJSON" $
269 infixApp (var "toJSON") "." (var (fname p k))
270 ]
272 _ ->
273 InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
274 [ wildcardD "toJSON" g omit none (map encode rs)
275 ]
277 omit = app (var "object")
278 . app (var "catMaybes")
279 . listE
281 none = var "emptyObject"
283 encode (l, s)
284 | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a
285 | otherwise = app (var "Just") (infixApp n ".=" a)
286 where
287 n = fstr l
288 a = var (fname p l)
289 o = var ".="
291wildcardD :: String
292 -> Global
293 -> ([Exp] -> Exp)
294 -> Exp
295 -> [Exp]
296 -> InstDecl
297wildcardD f n enc x = \case
298 [] -> constD f x
299 xs -> InsDecl (FunBind [match prec xs])
300 where
301 match p es =
302 Match noLoc (name f) [p] Nothing (UnGuardedRhs (enc es)) noBinds
304 prec = PRec (UnQual (dname n)) [PFieldWildcard]
306defJS :: Local -> Exp -> Exp
307defJS n x = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!=" x
309reqJS :: Local -> Exp
310reqJS = infixApp (var "o") ".:" . fstr
312optJS :: Local -> Exp
313optJS = infixApp (var "o") ".:?" . fstr
315funD :: String -> Exp -> InstDecl
316funD f = InsDecl . patBind noLoc (pvar (name f))
318constD :: String -> Exp -> InstDecl
319constD f x = InsDecl $
320 sfun noLoc (name f) [] (UnGuardedRhs (app (var "const") x)) noBinds
322ctorE :: Global -> [Exp] -> Exp
323ctorE n = seqE (var (dname n)) . map paren
325seqE :: Exp -> [Exp] -> Exp
326seqE l [] = app (var "pure") l
327seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
329objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl
330objDecl n p ds rs = DataDecl noLoc arity [] d [] [conDecl d p rs] (der ds)
331 where
332 d = dname n
334 arity | Map.size rs == 1 = NewType
335 | otherwise = DataType
337 der = map ((,[]) . unqual . drop 1 . show)
339conDecl :: Name -> Prefix -> Map Local Solved -> QualConDecl
340conDecl n p rs = QualConDecl noLoc [] [] body
341 where
342 body = case Map.toList rs of
343 [] -> ConDecl n []
344 [x] -> RecDecl n [field internalType x]
345 xs -> RecDecl n (map (field (strict . internalType)) xs)
347 field f (l, v) = ([fname p l], f (_type v))
349ctorSig :: Global -> Map Local Solved -> Decl
350ctorSig n rs = TypeSig noLoc [cname n] ts
351 where
352 ts = foldr' TyFun (TyCon (UnQual (dname n))) ps
353 ps = parameters (Map.elems rs)
355ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl
356ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
357 where
358 c = cname n
359 d = dname n
361 rhs | Map.null rs = var d
362 | otherwise = RecConstr (UnQual d) $
363 map (uncurry (fieldUpdate p)) (Map.toList rs)
365 ps = map (pname p) . Map.keys $ Map.filter required rs
367fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate
368fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
369 where
370 rhs | required s = v
371 | Just x <- def s, s ^. iRepeated = listE [x]
372 | Just x <- def s = x
373 | Just x <- iso (_type s) = infixApp x "#" v
374 | otherwise = var (name "Nothing")
376 v = var (pname p l)
378lensSig :: Global -> Prefix -> Local -> Solved -> Decl
379lensSig n p l s = TypeSig noLoc [lname p l] $
380 TyApp (TyApp (TyCon "Lens'") (tycon n))
381 (externalType (_type s))
383lensDecl :: Prefix -> Local -> Solved -> Decl
384lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
385 where
386 f = fname p l
387 t = _type s
389 rhs = mapping t $
390 app (app (var "lens") (var f))
391 (paren (lamE noLoc [pvar "s", pvar "a"]
392 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
394parameters :: [Solved] -> [Type]
395parameters = map (externalType . _type) . filter required
397def :: Solved -> Maybe Exp
398def s
399 | Just x <- s ^. iDefault = Just (go x (_prefix s) (_schema s))
400 | otherwise = Nothing
401 where
402 go x p = \case
403 SEnm {} -> var (bname p x)
404 SLit _ Bool -> lit (upperHead x)
405 SLit _ Text -> str x
406 SLit {} -> lit x
407 e -> error $ "Unsupported default value: " ++ show e
409 lit = var . name . Text.unpack
411terminalType :: TType -> Type
412terminalType = internalType . go
413 where
414 go (TMaybe x) = go x
415 go (TList x) = go x
416 go x = x
418externalType :: TType -> Type
419externalType = \case
420 TType r -> tycon r
421 TMaybe t@TList {} -> externalType t
422 TMaybe t -> TyApp (TyCon "Maybe") (externalType t)
423 TList t -> TyList (externalType t)
424 TLit l -> externalLit l
425 TMap k v ->
426 TyApp (TyApp (TyCon "HashMap") (externalType k)) (externalType (require v))
428internalType :: TType -> Type
429internalType = \case
430 TType r -> tycon r
431 TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
432 TList t -> TyList (internalType t)
433 TLit l -> internalLit l
434 TMap k v ->
435 TyApp (TyApp (TyCon "HashMap") (internalType k)) (internalType (require v))
437externalLit :: Lit -> Type
438externalLit = \case
439 Text -> TyCon "Text"
440 Bool -> TyCon "Bool"
441 Time -> TyCon "TimeOfDay"
442 Date -> TyCon "Day"
443 DateTime -> TyCon "UTCTime"
444 Nat -> TyCon "Natural"
445 Float -> TyCon "Float"
446 Double -> TyCon "Double"
447 Byte -> TyCon "Word8"
448 UInt32 -> TyCon "Word32"
449 UInt64 -> TyCon "Word64"
450 Int32 -> TyCon "Int32"
451 Int64 -> TyCon "Int64"
453 Alt t -> TyCon (unqual (Text.unpack t))
454 RqBody -> TyCon "Body"
455 RsBody -> TyCon "Stream"
456 JSONValue -> TyCon "JSONValue"
458internalLit :: Lit -> Type
459internalLit = \case
460 Text -> TyCon "Text"
461 Bool -> TyCon "Bool"
462 Time -> TyCon "Time'"
463 Date -> TyCon "Date'"
464 DateTime -> TyCon "DateTime'"
465 Nat -> TyCon "Nat"
466 Float -> TyCon "Float"
467 Double -> TyCon "Double"
468 Byte -> TyCon "Word8"
469 UInt32 -> TyCon "Word32"
470 UInt64 -> TyCon "Word64"
471 Int32 -> TyCon "Int32"
472 Int64 -> TyCon "Int64"
474 Alt t -> TyCon (unqual (Text.unpack t))
475 RqBody -> TyCon "Body"
476 RsBody -> TyCon "Stream"
477 JSONValue -> TyCon "JSONValue"
479mapping :: TType -> Exp -> Exp
480mapping t e = infixE e "." (go t)
481 where
482 go = \case
483 TMaybe x@(TList {}) -> var "_Default" : go x
484 TMaybe x -> nest (go x)
485 x -> maybeToList (iso x)
487 nest [] = []
488 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]
490iso :: TType -> Maybe Exp
491iso = \case
492 TList {} -> Just (var "_Coerce")
493 TLit Nat -> Just (var "_Nat")
494 TLit Time -> Just (var "_Time")
495 TLit Date -> Just (var "_Date")
496 TLit DateTime -> Just (var "_DateTime")
497 _ -> Nothing
499require :: TType -> TType
500require (TMaybe t) = t
501require t = t
503strict :: Type -> Type
504strict = TyBang BangedTy . \case
505 t@TyApp{} -> TyParen t
506 t -> t
508sing :: Text -> Type
509sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
511tylist :: [Text] -> Type
512tylist xs = TyCon . UnQual . name . Text.unpack $
513 "'[" <> Text.intercalate ", " xs <> "]"
515tycon :: Global -> Type
516tycon = TyCon . UnQual . dname
518unqual :: String -> QName
519unqual = UnQual . name
521infixE :: Exp -> QOp -> [Exp] -> Exp
522infixE l _ [] = l
523infixE l o (r:rs) = infixE (infixApp l o r) o rs
525str :: Text -> Exp
526str = strE . Text.unpack