git.iko.soy/gogol
on 4babe4f help sign in
gogol/gen/src/Gen/Syntax.hs
385 lines 12 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.Foldable (find, foldl', foldr')
18import Data.Hashable
19import qualified Data.HashMap.Strict as Map
20import Data.Maybe
21import Data.Maybe
22import Data.Semigroup ((<>))
23import Data.String
24import Data.Text (Text)
25import qualified Data.Text as Text
26import Data.Text.Manipulate
27import Gen.Orphans
28import Gen.Text
29import Gen.Types
30import Language.Haskell.Exts.Build
31import Language.Haskell.Exts.SrcLoc
32import Language.Haskell.Exts.Syntax hiding (Int, Lit)
34urlSig :: Name -> Decl
35urlSig n = TypeSig noLoc [n] (TyCon "BaseUrl")
37urlDecl :: Name -> String -> Text -> Integer -> Decl
38urlDecl n s u p = sfun noLoc n [] (UnGuardedRhs rhs) noBinds
39 where
40 rhs = appFun (var "BaseUrl") [var (name s), str u, intE p]
42 -- type API = :<|> ...
43apiAlias :: Name -> [Name] -> Decl
44apiAlias n ls = TypeDecl noLoc n [] alias
45 where
46 alias = case map (TyCon . UnQual) ls of
47 [] -> unit_tycon
48 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
50-- type Method = :> ...
51verbAlias :: Name -> Method Solved -> Decl
52verbAlias n m = TypeDecl noLoc n [] alias
53 where
54 alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) verb (path ++ qry)
56 -- FIXME: rather than using 'terminal' to get the terminal type,
57 -- write a custom 'Link' for servant to specify required params.
59 path :: [Type]
60 path = map match
61 . filter (not . Text.null)
62 $ Text.split (== '/') (_mPath m)
63 where
64 -- FIXME: should error if '{' '}' is found and cannot find the ref.
65 match x
66 | Just (c, t) <- Text.uncons x
67 , c == '{'
68 , Just k <- Map.lookup (toKey (Text.init t)) params
69 , _pLocation k == Path
70 = TyApp (TyApp (TyCon "Capture")
71 (sing (Text.init t)))
72 (terminalType (_type (_pParam k)))
73 | otherwise = sing x
75 -- FIXME: order by _mParameterOrder
76 qry :: [Type]
77 qry = mapMaybe f (Map.toList params)
78 where
79 f (k, x) =
80 let t = terminalType (_type (_pParam x))
81 n = sing (local k)
82 in case _pLocation x of
83 Query | x ^. iRepeated
84 -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t
85 Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t
86 Path -> Nothing
88 params = _mParameters m
90 verb :: Type
91 verb = TyApp (TyApp meth typ) res
92 where
93 meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mHttpMethod m)
94 typ = TyCon "'[JSON]"
95 res = maybe (TyCon "()") (tycon . ref) (_mResponse m)
97requestDecl :: Global
98 -> Prefix
99 -> Name
100 -> Name
101 -> [Local]
102 -> Method Solved -> Decl
103requestDecl n p api url fs m =
104 -- FIXME: associated Rs type
105 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [tycon n]
106 [ response
107 , request
108 , requestWithRoute
109 ]
110 where
111 response = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
112 maybe unit_tycon (tycon . ref) (_mResponse m)
114 request = funD "request" $
115 appFun (var "requestWithRoute") [var "defReq", var url]
117 requestWithRoute = InsDecl (FunBind [match])
118 where
119 match = Match noLoc (name "requestWithRoute") pats Nothing rhs decls
121 decls = BDecls
122 [ patBind noLoc (pvar "go") $
123 appFun (var "clientWithRoute") $
124 [ ExpTypeSig noLoc (var "Proxy") $
125 TyApp (TyCon "Proxy") (TyCon (UnQual api))
126 , var "r"
127 , var "u"
128 ]
129 ]
131 rhs = UnGuardedRhs $ appFun (var "go") (map go fs)
132 where
133 go l | Just p <- Map.lookup l ps
134 , _pLocation p == Query
135 , parameter p || defaulted p = app (var "Just") (v l)
136 | otherwise = v l
138 ps = _mParameters m
139 v = var . fname p
141 pats = [pvar "r", pvar "u", prec]
142 prec = PRec (UnQual (dname n)) [PFieldWildcard]
144jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
145jsonDecls g p (Map.toList -> rs) = [from, to]
146 where
147 from = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
148 [ funD "parseJSON" $
149 app (app (var "withObject") (dstr g)) $
150 lamE noLoc [pvar "o"] $
151 ctorE g (map decode rs)
152 ]
154 decode (l, s)
155 | Just x <- def s = defJS l x
156 | required s = reqJS l
157 | monoid s = defJS l (var "mempty")
158 | otherwise = optJS l
160 to = InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
161 [ wildcardD "toJSON" g omit none (map encode rs)
162 ]
164 omit = app (var "object")
165 . app (var "catMaybes")
166 . listE
168 none = paren $ app (var "Object") (var "mempty")
170 encode (l, s)
171 | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a
172 | otherwise = app (var "Just") (infixApp n ".=" a)
173 where
174 n = fstr l
175 a = var (fname p l)
176 o = var ".="
178wildcardD :: String
179 -> Global
180 -> ([Exp] -> Exp)
181 -> Exp
182 -> [Exp]
183 -> InstDecl
184wildcardD f n enc x = \case
185 [] -> constD f x
186 xs -> InsDecl (FunBind [match prec xs])
187 where
188 match p es =
189 Match noLoc (name f) [p] Nothing (UnGuardedRhs (enc es)) noBinds
191 prec = PRec (UnQual (dname n)) [PFieldWildcard]
193defJS :: Local -> Exp -> Exp
194defJS n x = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!=" x
196reqJS :: Local -> Exp
197reqJS = infixApp (var "o") ".:" . fstr
199optJS :: Local -> Exp
200optJS = infixApp (var "o") ".:?" . fstr
202funD :: String -> Exp -> InstDecl
203funD f = InsDecl . patBind noLoc (pvar (name f))
205constD :: String -> Exp -> InstDecl
206constD f x = InsDecl $
207 sfun noLoc (name f) [] (UnGuardedRhs (app (var "const") x)) noBinds
209ctorE :: Global -> [Exp] -> Exp
210ctorE n = seqE (var (dname n)) . map paren
212seqE :: Exp -> [Exp] -> Exp
213seqE l [] = app (var "pure") l
214seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
216objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl
217objDecl n p ds rs = DataDecl noLoc arity [] d [] [conDecl d p rs] (der ds)
218 where
219 d = dname n
221 arity | Map.size rs == 1 = NewType
222 | otherwise = DataType
224 der = map ((,[]) . unqual . drop 1 . show)
226conDecl :: Name -> Prefix -> Map Local Solved -> QualConDecl
227conDecl n p rs = QualConDecl noLoc [] [] body
228 where
229 body = case Map.toList rs of
230 [] -> ConDecl n []
231 [x] -> RecDecl n [field internalType x]
232 xs -> RecDecl n (map (field (strict . internalType)) xs)
234 field f (l, v) = ([fname p l], f (_type v))
236ctorSig :: Global -> Map Local Solved -> Decl
237ctorSig n rs = TypeSig noLoc [cname n] ts
238 where
239 ts = foldr' TyFun (TyCon (UnQual (dname n))) ps
240 ps = parameters (Map.elems rs)
242ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl
243ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
244 where
245 c = cname n
246 d = dname n
248 rhs | Map.null rs = var d
249 | otherwise = RecConstr (UnQual d) $
250 map (uncurry (fieldUpdate p)) (Map.toList rs)
252 ps = map (pname p) . Map.keys $ Map.filter required rs
254fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate
255fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
256 where
257 rhs | required s = v
258 | Just x <- def s = x
259 | Just x <- iso (_type s) = infixApp x "#" v
260 | otherwise = var (name "Nothing")
262 v = var (pname p l)
264lensSig :: Global -> Prefix -> Local -> Solved -> Decl
265lensSig n p l s = TypeSig noLoc [lname p l] $
266 TyApp (TyApp (TyCon "Lens'") (tycon n))
267 (externalType (_type s))
269lensDecl :: Prefix -> Local -> Solved -> Decl
270lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
271 where
272 f = fname p l
273 t = _type s
275 rhs = mapping t $
276 app (app (var "lens") (var f))
277 (paren (lamE noLoc [pvar "s", pvar "a"]
278 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
280parameters :: [Solved] -> [Type]
281parameters = map (externalType . _type) . filter required
283def :: Solved -> Maybe Exp
284def s
285 | Just x <- s ^. iDefault = Just (go x (_prefix s) (_schema s))
286 | otherwise = Nothing
287 where
288 go x p = \case
289 SEnm {} -> var (bname p x)
290 SLit _ Bool -> lit (upperHead x)
291 SLit _ Text -> str x
292 SLit {} -> lit x
293 e -> error $ "Unsupported default value: " ++ show e
295 lit = var . name . Text.unpack
297terminalType :: TType -> Type
298terminalType = internalType . go
299 where
300 go (TMaybe x) = x
301 go (TList x) = x
302 go x = x
304externalType :: TType -> Type
305externalType = \case
306 TType r -> tycon r
307 TMaybe t@TList {} -> externalType t
308 TMaybe t -> TyApp (TyCon "Maybe") (externalType t)
309 TList t -> TyList (externalType t)
310 TLit l -> externalLit l
312internalType :: TType -> Type
313internalType = \case
314 TType r -> tycon r
315 TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
316 TList t -> TyList (internalType t)
317 TLit l -> internalLit l
319externalLit :: Lit -> Type
320externalLit = \case
321 Text -> TyCon "Text"
322 Bool -> TyCon "Bool"
323 Time -> TyCon "UTCTime"
324 Date -> TyCon "UTCTime"
325 Nat -> TyCon "Natural"
326 Float -> TyCon "Float"
327 Double -> TyCon "Double"
328 Byte -> TyCon "Word8"
329 UInt32 -> TyCon "Word32"
330 UInt64 -> TyCon "Word64"
331 Int32 -> TyCon "Int32"
332 Int64 -> TyCon "Int64"
334internalLit :: Lit -> Type
335internalLit = \case
336 Text -> TyCon "Text"
337 Bool -> TyCon "Bool"
338 Time -> TyCon "UTCTime"
339 Date -> TyCon "UTCTime"
340 Nat -> TyCon "Nat"
341 Float -> TyCon "Float"
342 Double -> TyCon "Double"
343 Byte -> TyCon "Word8"
344 UInt32 -> TyCon "Word32"
345 UInt64 -> TyCon "Word64"
346 Int32 -> TyCon "Int32"
347 Int64 -> TyCon "Int64"
349mapping :: TType -> Exp -> Exp
350mapping t e = infixE e "." (go t)
351 where
352 go = \case
353 TMaybe x@(TList {}) -> var "_Default" : go x
354 TMaybe x -> nest (go x)
355 x -> maybeToList (iso x)
357 nest [] = []
358 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]
360iso :: TType -> Maybe Exp
361iso = \case
362 TList {} -> Just (var "_Coerce")
363 TLit Nat -> Just (var "_Nat")
364 _ -> Nothing
366strict :: Type -> Type
367strict = TyBang BangedTy . \case
368 t@TyApp{} -> TyParen t
369 t -> t
371sing :: Text -> Type
372sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
374tycon :: Global -> Type
375tycon = TyCon . UnQual . dname
377unqual :: String -> QName
378unqual = UnQual . name
380infixE :: Exp -> QOp -> [Exp] -> Exp
381infixE l _ [] = l
382infixE l o (r:rs) = infixE (infixApp l o r) o rs
384str :: Text -> Exp
385str = strE . Text.unpack