git.iko.soy/gogol
on 47fe2cd help sign in
gogol/gen/src/Gen/Syntax.hs
513 lines 16 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 "BaseUrl")
39urlDecl :: Name -> String -> Text -> Integer -> Decl
40urlDecl n s u p = sfun noLoc n [] (UnGuardedRhs rhs) noBinds
41 where
42 rhs = appFun (var "BaseUrl") [var (name s), str u, intE p]
44 -- type API = :<|> ...
45apiAlias :: Name -> [Name] -> Decl
46apiAlias n ls = TypeDecl noLoc n [] alias
47 where
48 alias = case map (TyCon . UnQual) ls of
49 [] -> unit_tycon
50 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
52-- type Method = :> ...
53verbAlias :: Name -> Method Solved -> Decl
54verbAlias n m
55 | _mSupportsMediaDownload m = TypeDecl noLoc n [] download
56 | otherwise = TypeDecl noLoc n [] rest
57 where
58 rest = alias verb (path ++ qry params ++ media)
59 download = TyInfix rest (UnQual (sym ":<|>")) $
60 alias (TyApp (TyApp meth octet) (TyCon "Body"))
61 (path ++ qry (Map.delete "alt" (_mParameters m)) ++ [alt] ++ media)
63 alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r)
65 path :: [Type]
66 path = map match $ extractPath (_mPath m)
67 where
68 match (Left t) = sing t
69 match (Right (l, c)) =
70 case Map.lookup l (_mParameters m) of
71 Nothing -> error $ "Unable to find path parameter " ++ show l
72 Just x ->
73 case c of
74 Nothing | x ^. iRepeated ->
75 TyApp (TyApp (TyCon "Captures")
76 (sing (local l)))
77 (terminalType (_type (_pParam x)))
79 Nothing ->
80 TyApp (TyApp (TyCon "Capture")
81 (sing (local l)))
82 (terminalType (_type (_pParam x)))
84 Just y ->
85 TyApp (TyApp (TyApp (TyCon "CaptureMode")
86 (sing (local l)))
87 (sing y))
88 (terminalType (_type (_pParam x)))
91 qry xs = mapMaybe f $ orderParams fst (Map.toList xs) (_mParameterOrder m)
92 where
93 f (k, x) =
94 let t = terminalType (_type (_pParam x))
95 n = sing (local k)
96 in case _pLocation x of
97 Query | x ^. iRepeated
98 -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t
99 Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t
100 Path -> Nothing
102 media :: [Type]
103 media | Just b <- _mRequest m
104 , _mSupportsMediaUpload m =
105 [TyApp (TyApp (TyApp (TyCon "MultipartRelated") json)
106 (tycon (ref b)))
107 (TyCon "Body")]
109 | Just b <- _mRequest m =
110 [TyApp (TyApp (TyCon "ReqBody") json) (tycon (ref b))]
112 | _mSupportsMediaUpload m =
113 [TyApp (TyApp (TyCon "ReqBody") octet) (TyCon "Body")]
115 | otherwise = []
117 verb = TyApp (TyApp meth json) $
118 maybe (TyCon "()") (tycon . ref) (_mResponse m)
120 meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mHttpMethod m)
122 octet = tylist ["OctetStream"]
123 json = tylist ["JSON"]
125 alt = TyApp (TyApp (TyCon "QueryParam") (sing "alt")) (TyCon "AltMedia")
127 params = Map.filter ((/= Path) . _pLocation) (_mParameters m)
129downloadDecl :: Global
130 -> Prefix
131 -> Name
132 -> Name
133 -> [Local]
134 -> Method Solved
135 -> Decl
136downloadDecl n p api url fs m =
137 googleRequestDecl n ty rs alt p api url fs m pat prec
138 where
139 ty = TyApp (TyCon "MediaDownload") (tycon n)
140 rs = InsType noLoc (TyApp (TyCon "Rs") ty) (TyCon "Body")
142 alt = Just (var "AltMedia")
144 pat | _mSupportsMediaDownload m = PInfixApp PWildCard (UnQual (sym ":<|>")) (pvar "go")
145 | otherwise = pvar "go"
147 prec = PApp (UnQual "MediaDownload") [PRec (UnQual (dname n)) [PFieldWildcard]]
149requestDecl :: Global
150 -> Prefix
151 -> Name
152 -> Name
153 -> [Local]
154 -> Method Solved
155 -> Decl
156requestDecl n p api url fs m =
157 googleRequestDecl n (tycon n) rs alt p api url fs m pat prec
158 where
159 rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
160 maybe unit_tycon (tycon . ref) (_mResponse m)
162 alt = var . name . Text.unpack . alternate <$>
163 (Map.lookup "alt" (_mParameters m) >>= view iDefault)
165 pat | _mSupportsMediaDownload m = PInfixApp (pvar "go") (UnQual (sym ":<|>")) PWildCard
166 | otherwise = pvar "go"
168 prec = PRec (UnQual (dname n)) [PFieldWildcard]
170googleRequestDecl :: Global
171 -> Type
172 -> InstDecl
173 -> Maybe Exp
174 -> Prefix
175 -> Name
176 -> Name
177 -> [Local]
178 -> Method Solved
179 -> Pat
180 -> Pat
181 -> Decl
182googleRequestDecl g n assoc alt p api url fields m pat prec =
183 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n]
184 [ assoc
185 , request
186 , requestWithRoute
187 ]
188 where
189 request = funD "request" $
190 appFun (var "requestWithRoute") [var "defReq", var url]
192 requestWithRoute = InsDecl (FunBind [match])
193 where
194 match = Match noLoc (name "requestWithRoute") pats Nothing rhs decls
196 decls = BDecls
197 [ patBind noLoc pat $
198 appFun (var "clientWithRoute") $
199 [ ExpTypeSig noLoc (var "Proxy") $
200 TyApp (TyCon "Proxy") (TyCon (UnQual api))
201 , var "r"
202 , var "u"
203 ]
204 ]
206 rhs = UnGuardedRhs . appFun (var "go") $ map go fs'
207 ++ maybeToList (app (var "Just") <$> alt)
208 ++ maybeToList (go <$> rq)
209 ++ maybeToList (go <$> pay)
210 where
211 go l = case Map.lookup l ps of
212 Just p | _pLocation p == Query
213 , defaulted p
214 , p ^. iRepeated -> v l
216 Just p | _pLocation p == Query
217 , not (required p)
218 , p ^. iRepeated -> infixApp (v l) "^." (var "_Default")
220 Just p | _pLocation p == Query
221 , not (p ^. iRepeated)
222 , parameter p || defaulted p -> app (var "Just") (v l)
224 _ -> v l
226 ps = _mParameters m
227 v = var . fname p
229 (fs', rq) | Just _ <- _mRequest m = (delete "payload" fs, Just "payload")
230 | otherwise = (fs, Nothing)
232 pay | _mSupportsMediaUpload m = Just "media"
233 | otherwise = Nothing
235 fs = delete "alt"
236 . orderParams id (Map.keys (_mParameters m))
237 . nub
238 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m
240 pats = [pvar "r", pvar "u", prec]
242authDecl :: Global -> Prefix -> [Local] -> Decl
243authDecl g p fs = InstDecl noLoc Nothing [] [] (unqual "GoogleAuth") [tycon g]
244 [ method "authKey" "key"
245 , method "authToken" "oauth_token"
246 ]
247 where
248 method l f
249 | f `elem` fs = funD l (infixApp (var (lname p f)) "." (var "_Just"))
250 | otherwise = funD l (app (var "const") (var "pure"))
252jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
253jsonDecls g p (Map.toList -> rs) = [from, to]
254 where
255 from = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
256 [ funD "parseJSON" $
257 app (app (var "withObject") (dstr g)) $
258 lamE noLoc [pvar "o"] $
259 ctorE g (map decode rs)
260 ]
262 decode (l, s)
263 | Just x <- def s = defJS l x
264 | required s = reqJS l
265 | monoid s = defJS l (var "mempty")
266 | otherwise = optJS l
268 to = InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
269 [ wildcardD "toJSON" g omit none (map encode rs)
270 ]
272 omit = app (var "object")
273 . app (var "catMaybes")
274 . listE
276 none = var "emptyObject"
278 encode (l, s)
279 | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a
280 | otherwise = app (var "Just") (infixApp n ".=" a)
281 where
282 n = fstr l
283 a = var (fname p l)
284 o = var ".="
286wildcardD :: String
287 -> Global
288 -> ([Exp] -> Exp)
289 -> Exp
290 -> [Exp]
291 -> InstDecl
292wildcardD f n enc x = \case
293 [] -> constD f x
294 xs -> InsDecl (FunBind [match prec xs])
295 where
296 match p es =
297 Match noLoc (name f) [p] Nothing (UnGuardedRhs (enc es)) noBinds
299 prec = PRec (UnQual (dname n)) [PFieldWildcard]
301defJS :: Local -> Exp -> Exp
302defJS n x = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!=" x
304reqJS :: Local -> Exp
305reqJS = infixApp (var "o") ".:" . fstr
307optJS :: Local -> Exp
308optJS = infixApp (var "o") ".:?" . fstr
310funD :: String -> Exp -> InstDecl
311funD f = InsDecl . patBind noLoc (pvar (name f))
313constD :: String -> Exp -> InstDecl
314constD f x = InsDecl $
315 sfun noLoc (name f) [] (UnGuardedRhs (app (var "const") x)) noBinds
317ctorE :: Global -> [Exp] -> Exp
318ctorE n = seqE (var (dname n)) . map paren
320seqE :: Exp -> [Exp] -> Exp
321seqE l [] = app (var "pure") l
322seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
324objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl
325objDecl n p ds rs = DataDecl noLoc arity [] d [] [conDecl d p rs] (der ds)
326 where
327 d = dname n
329 arity | Map.size rs == 1 = NewType
330 | otherwise = DataType
332 der = map ((,[]) . unqual . drop 1 . show)
334conDecl :: Name -> Prefix -> Map Local Solved -> QualConDecl
335conDecl n p rs = QualConDecl noLoc [] [] body
336 where
337 body = case Map.toList rs of
338 [] -> ConDecl n []
339 [x] -> RecDecl n [field internalType x]
340 xs -> RecDecl n (map (field (strict . internalType)) xs)
342 field f (l, v) = ([fname p l], f (_type v))
344ctorSig :: Global -> Map Local Solved -> Decl
345ctorSig n rs = TypeSig noLoc [cname n] ts
346 where
347 ts = foldr' TyFun (TyCon (UnQual (dname n))) ps
348 ps = parameters (Map.elems rs)
350ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl
351ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
352 where
353 c = cname n
354 d = dname n
356 rhs | Map.null rs = var d
357 | otherwise = RecConstr (UnQual d) $
358 map (uncurry (fieldUpdate p)) (Map.toList rs)
360 ps = map (pname p) . Map.keys $ Map.filter required rs
362fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate
363fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
364 where
365 rhs | required s = v
366 | Just x <- def s, s ^. iRepeated = listE [x]
367 | Just x <- def s = x
368 | Just x <- iso (_type s) = infixApp x "#" v
369 | otherwise = var (name "Nothing")
371 v = var (pname p l)
373lensSig :: Global -> Prefix -> Local -> Solved -> Decl
374lensSig n p l s = TypeSig noLoc [lname p l] $
375 TyApp (TyApp (TyCon "Lens'") (tycon n))
376 (externalType (_type s))
378lensDecl :: Prefix -> Local -> Solved -> Decl
379lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
380 where
381 f = fname p l
382 t = _type s
384 rhs = mapping t $
385 app (app (var "lens") (var f))
386 (paren (lamE noLoc [pvar "s", pvar "a"]
387 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
389parameters :: [Solved] -> [Type]
390parameters = map (externalType . _type) . filter required
392def :: Solved -> Maybe Exp
393def s
394 | Just x <- s ^. iDefault = Just (go x (_prefix s) (_schema s))
395 | otherwise = Nothing
396 where
397 go x p = \case
398 SEnm {} -> var (bname p x)
399 SLit _ Bool -> lit (upperHead x)
400 SLit _ Text -> str x
401 SLit {} -> lit x
402 e -> error $ "Unsupported default value: " ++ show e
404 lit = var . name . Text.unpack
406terminalType :: TType -> Type
407terminalType = internalType . go
408 where
409 go (TMaybe x) = go x
410 go (TList x) = go x
411 go x = x
413externalType :: TType -> Type
414externalType = \case
415 TType r -> tycon r
416 TMaybe t@TList {} -> externalType t
417 TMaybe t -> TyApp (TyCon "Maybe") (externalType t)
418 TList t -> TyList (externalType t)
419 TLit l -> externalLit l
421internalType :: TType -> Type
422internalType = \case
423 TType r -> tycon r
424 TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
425 TList t -> TyList (internalType t)
426 TLit l -> internalLit l
428externalLit :: Lit -> Type
429externalLit = \case
430 Text -> TyCon "Text"
431 Bool -> TyCon "Bool"
432 Time -> TyCon "TimeOfDay"
433 Date -> TyCon "LocalTime"
434 DateTime -> TyCon "UTCTime"
435 Nat -> TyCon "Natural"
436 Float -> TyCon "Float"
437 Double -> TyCon "Double"
438 Byte -> TyCon "Word8"
439 UInt32 -> TyCon "Word32"
440 UInt64 -> TyCon "Word64"
441 Int32 -> TyCon "Int32"
442 Int64 -> TyCon "Int64"
444 Alt t -> TyCon (unqual (Text.unpack t))
445 Key -> TyCon "Key"
446 OAuthToken -> TyCon "OAuthToken"
447 Body -> TyCon "Body"
449internalLit :: Lit -> Type
450internalLit = \case
451 Text -> TyCon "Text"
452 Bool -> TyCon "Bool"
453 Time -> TyCon "Time'"
454 Date -> TyCon "Date'"
455 DateTime -> TyCon "DateTime'"
456 Nat -> TyCon "Nat"
457 Float -> TyCon "Float"
458 Double -> TyCon "Double"
459 Byte -> TyCon "Word8"
460 UInt32 -> TyCon "Word32"
461 UInt64 -> TyCon "Word64"
462 Int32 -> TyCon "Int32"
463 Int64 -> TyCon "Int64"
465 Alt t -> TyCon (unqual (Text.unpack t))
466 Key -> TyCon "Key"
467 OAuthToken -> TyCon "OAuthToken"
468 Body -> TyCon "Body"
470mapping :: TType -> Exp -> Exp
471mapping t e = infixE e "." (go t)
472 where
473 go = \case
474 TMaybe x@(TList {}) -> var "_Default" : go x
475 TMaybe x -> nest (go x)
476 x -> maybeToList (iso x)
478 nest [] = []
479 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]
481iso :: TType -> Maybe Exp
482iso = \case
483 TList {} -> Just (var "_Coerce")
484 TLit Nat -> Just (var "_Nat")
485 TLit Time -> Just (var "_Time")
486 TLit Date -> Just (var "_Date")
487 TLit DateTime -> Just (var "_DateTime")
488 _ -> Nothing
490strict :: Type -> Type
491strict = TyBang BangedTy . \case
492 t@TyApp{} -> TyParen t
493 t -> t
495sing :: Text -> Type
496sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
498tylist :: [Text] -> Type
499tylist xs = TyCon . UnQual . name . Text.unpack $
500 "'[" <> Text.intercalate ", " xs <> "]"
502tycon :: Global -> Type
503tycon = TyCon . UnQual . dname
505unqual :: String -> QName
506unqual = UnQual . name
508infixE :: Exp -> QOp -> [Exp] -> Exp
509infixE l _ [] = l
510infixE l o (r:rs) = infixE (infixApp l o r) o rs
512str :: Text -> Exp
513str = strE . Text.unpack