git.iko.soy/gogol
on develop help sign in
Adding ghetto alt
8399a3cBrendan Hay
gen/src/Gen/AST/Flatten.hs+13−10
compare with develop
unifiedsplit
@@ -29,6 +29,7 @@ import Control.Monad.Except
29import qualified Data.HashMap.Strict as Map
29import qualified Data.HashMap.Strict as Map
30import Data.Maybe
30import Data.Maybe
31import Data.Semigroup ((<>))
31import Data.Semigroup ((<>))
32+import qualified Data.Text as Text
32import Gen.Formatting
33import Gen.Formatting
33import Gen.Types
34import Gen.Types
34import Prelude hiding (sum)
35import Prelude hiding (sum)
@@ -81,11 +82,13 @@ schema g ml (Fix f) = go f >>= insert this
81 Obj Nothing <$> Map.traverseWithKey (localSchema this) ps
82 Obj Nothing <$> Map.traverseWithKey (localSchema this) ps
82
83
83globalParam :: Local -> Param (Fix Schema) -> AST (Param Global)
84globalParam :: Local -> Param (Fix Schema) -> AST (Param Global)
84−globalParam l = case l of
85+globalParam l p = ($ p) $ case l of
85− "alt" -> overrideParam l Alt
86+ "alt" -> overrideParam l (Alt alt)
86− "key" -> overrideParam l Key
87+ "key" -> overrideParam l Key
87− "oauth_token" -> overrideParam l OAuthToken
88+ "oauth_token" -> overrideParam l OAuthToken
88− _ -> localParam "" l
89+ _ -> localParam "" l
90+ where
91+ alt = Text.toUpper (fromMaybe "JSON" (p ^. iDefault))
89
92
90overrideParam :: Local -> Lit -> Param (Fix Schema) -> AST (Param Global)
93overrideParam :: Local -> Lit -> Param (Fix Schema) -> AST (Param Global)
91overrideParam l v p =
94overrideParam l v p =
@@ -121,15 +124,14 @@ method qs suf m@Method {..} = do
121
124
122 b <- body typ
125 b <- body typ
123
126
124− let params = ps <> qs
127+ let params = ps <> qs
125− fields = b (upload (Map.map _pParam params))
128+ fields = Map.delete "alt" $ b (upload (Map.map _pParam params))
126
129
127 void $ insert typ (SObj schemaInfo (Obj Nothing fields))
130 void $ insert typ (SObj schemaInfo (Obj Nothing fields))
128 pure $! m { _mParameters = params }
131 pure $! m { _mParameters = params }
129 where
132 where
130 schemaInfo = emptyInfo { _iDescription = _mDescription }
133 schemaInfo = emptyInfo { _iDescription = _mDescription }
131−
132− bodyInfo = requiredInfo { _iDescription = Just "Multipart request metadata." }
134+ bodyInfo = requiredInfo { _iDescription = Just "Multipart request metadata." }
133
135
134 body p = case _mRequest of
136 body p = case _mRequest of
135 Nothing -> pure id
137 Nothing -> pure id
@@ -138,11 +140,12 @@ method qs suf m@Method {..} = do
138 g <- localSchema p f (Fix (SRef bodyInfo x))
140 g <- localSchema p f (Fix (SRef bodyInfo x))
139 pure (Map.insert f g)
141 pure (Map.insert f g)
140
142
143+ -- FIXME: Add maxSize to media field description.
141 upload
144 upload
142 | _mSupportsMediaUpload = Map.insert "media" "Body"
145 | _mSupportsMediaUpload = Map.insert "media" "Body"
143 | otherwise = id
146 | otherwise = id
144
147
145− download = id
148+ -- download = id
146
149
147 -- media
150 -- media
148 -- insert 'media' property of type 'Body'
151 -- insert 'media' property of type 'Body'
gen/src/Gen/AST/Render.hs+32−29
@@ -90,35 +90,6 @@ renderSchema s = go (_schema s)
90 "' with the minimum fields required to make a request.\n")
90 "' with the minimum fields required to make a request.\n")
91 k
91 k
92
92
93−renderMethod :: Service a -> NS -> Suffix -> Method Solved -> AST Action
94−renderMethod s root suf m@Method {..} = do
95− x@Solved {..} <- getSolved typ
96− Just d <- renderSchema x
97−
98− i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m
99−
100− Action _mId _unique (root <> mkNS ns) _mDescription alias
101− <$> pp Print (verbAlias alias m)
102− <*> pure (insts [i] d)
103− where
104− (alias, typ, ns) = mname (_sCanonicalName s) suf _mId
105−
106− url = name (Text.unpack (urlName s))
107−
108− insts is = \case
109− Prod n h r c ls _ -> Prod n h r c ls is
110− d -> d
111−
112− props = \case
113− SObj _ (Obj _ ps) -> Map.keys ps
114− _ -> mempty
115−
116−renderResource :: Service a -> NS -> Suffix -> Resource Solved -> AST [Action]
117−renderResource s root suf Resource {..} =
118− liftA2 (<>)
119− (traverse (renderResource s root suf) (Map.elems _rResources) <&> concat)
120− (traverse (renderMethod s root suf) _rMethods)
121−
122renderAPI :: Service Solved -> AST API
93renderAPI :: Service Solved -> AST API
123renderAPI s = do
94renderAPI s = do
124 rs <- traverse (renderResource s resourceNS "Resource")
95 rs <- traverse (renderResource s resourceNS "Resource")
@@ -148,6 +119,38 @@ renderAPI s = do
148 "@ of the " % stext % ".")
119 "@ of the " % stext % ".")
149 (s ^. dVersion) (s ^. dTitle)
120 (s ^. dVersion) (s ^. dTitle)
150
121
122+renderMethod :: Service a -> NS -> Suffix -> Method Solved -> AST Action
123+renderMethod s root suf m@Method {..} = do
124+ x@Solved {..} <- getSolved typ
125+ Just d <- renderSchema x
126+
127+ i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m
128+ dl <- pp Print $ downloadDecl _unique _prefix alias url (props _schema) m
129+
130+ let is = i : [dl | _mSupportsMediaDownload]
131+
132+ Action _mId _unique (root <> mkNS ns) _mDescription alias
133+ <$> pp Print (verbAlias alias m)
134+ <*> pure (insts is d)
135+ where
136+ (alias, typ, ns) = mname (_sCanonicalName s) suf _mId
137+
138+ url = name (Text.unpack (urlName s))
139+
140+ insts is = \case
141+ Prod n h r c ls _ -> Prod n h r c ls is
142+ d -> d
143+
144+ props = \case
145+ SObj _ (Obj _ ps) -> Map.keys ps
146+ _ -> mempty
147+
148+renderResource :: Service a -> NS -> Suffix -> Resource Solved -> AST [Action]
149+renderResource s root suf Resource {..} =
150+ liftA2 (<>)
151+ (traverse (renderResource s root suf) (Map.elems _rResources) <&> concat)
152+ (traverse (renderMethod s root suf) _rMethods)
153+
151data PP
154data PP
152 = Indent
155 = Indent
153 | Print
156 | Print
gen/src/Gen/AST/Solve.hs+8−8
@@ -113,15 +113,15 @@ getDerive g = loc "getDerive" g $ memo derived g go
113 SObj _ (Obj _ ps) -> foldM props base (Map.elems ps)
113 SObj _ (Obj _ ps) -> foldM props base (Map.elems ps)
114
114
115 literal = \case
115 literal = \case
116− Text -> base <> [DOrd, DIsString]
116+ Text -> base <> [DOrd, DIsString]
117− Bool -> enum
117+ Bool -> enum
118− Time -> base
118+ Time -> base
119− Date -> base
119+ Date -> base
120− Body -> base
120+ Body -> base
121− Alt -> base
121+ Alt _ -> base
122− Key -> base
122+ Key -> base
123 -- FIXME: Add numeric cases
123 -- FIXME: Add numeric cases
124− _ -> [DNum, DIntegral, DReal] <> enum
124+ _ -> [DNum, DIntegral, DReal] <> enum
125
125
126 props ds x = intersect ds <$> getDerive x
126 props ds x = intersect ds <$> getDerive x
127
127
gen/src/Gen/Syntax.hs+70−28
@@ -49,12 +49,16 @@ apiAlias n ls = TypeDecl noLoc n [] alias
49
49
50-- type Method = :> ...
50-- type Method = :> ...
51verbAlias :: Name -> Method Solved -> Decl
51verbAlias :: Name -> Method Solved -> Decl
52−verbAlias n m = TypeDecl noLoc n [] (alias (path ++ qry ++ media))
52+verbAlias n m
53+ | _mSupportsMediaDownload m = TypeDecl noLoc n [] download
54+ | otherwise = TypeDecl noLoc n [] rest
53 where
55 where
56+ rest = alias verb (path ++ qry params ++ media)
54− alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) verb
57+ download = TyInfix rest (UnQual (sym ":<|>")) $
58+ alias (TyApp (TyApp meth octet) (TyCon "Stream"))
59+ (path ++ qry (Map.delete "alt" (_mParameters m)) ++ [alt] ++ media)
55
60
56− -- FIXME: rather than using 'terminal' to get the terminal type,
61+ alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r)
57− -- write a custom 'Link' for servant to specify required params.
58
62
59 path :: [Type]
63 path :: [Type]
60 path = map match
64 path = map match
@@ -73,8 +77,8 @@ verbAlias n m = TypeDecl noLoc n [] (alias (path ++ qry ++ media))
73 | otherwise = sing x
77 | otherwise = sing x
74
78
75 -- FIXME: order by _mParameterOrder
79 -- FIXME: order by _mParameterOrder
76− qry :: [Type]
80+-- qry :: [Type]
77− qry = mapMaybe f (Map.toList params)
81+ qry = mapMaybe f . Map.toList
78 where
82 where
79 f (k, x) =
83 f (k, x) =
80 let t = terminalType (_type (_pParam x))
84 let t = terminalType (_type (_pParam x))
@@ -89,39 +93,74 @@ verbAlias n m = TypeDecl noLoc n [] (alias (path ++ qry ++ media))
89 media | Just b <- _mRequest m =
93 media | Just b <- _mRequest m =
90 let g = ref b
94 let g = ref b
91 in if _mSupportsMediaUpload m
95 in if _mSupportsMediaUpload m
92− then [TyApp (TyApp (TyCon "Multipart") typ) (parts g)]
96+ then [TyApp (TyApp (TyCon "Multipart") json) (parts g)]
93− else [TyApp (TyApp (TyCon "ReqBody") typ) (tycon g)]
97+ else [TyApp (TyApp (TyCon "ReqBody") json) (tycon g)]
94 | otherwise = []
98 | otherwise = []
95 where
99 where
96− parts g = TyCon (UnQual (name (Text.unpack ("'[" <> global g <> ", Body]"))))
100+ parts g = TyCon . UnQual . name . Text.unpack $
97− typ = TyCon "'[JSON]"
101+ "'[" <> global g <> ", Body]"
98
102
99− verb :: Type
100− verb = TyApp (TyApp meth typ) res
103+ verb = TyApp (TyApp meth json) $
101− where
104+ maybe (TyCon "()") (tycon . ref) (_mResponse m)
105+
102− meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mHttpMethod m)
106+ meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mHttpMethod m)
107+
108+ octet = TyCon "'[OctetStream]"
103− typ = TyCon "'[JSON]"
109+ json = TyCon "'[JSON]"
104− res = maybe (TyCon "()") (tycon . ref) (_mResponse m)
110+
111+ alt = TyApp (TyApp (TyCon "QueryParam") (sing "alt")) (TyCon "Media")
105
112
106 params = _mParameters m
113 params = _mParameters m
107
114
115+downloadDecl :: Global
116+ -> Prefix
117+ -> Name
118+ -> Name
119+ -> [Local]
120+ -> Method Solved
121+ -> Decl
122+downloadDecl n p api url fs m =
123+ googleRequestDecl n (tycon n) rs alt p api url fs m
124+ where
125+ rs = InsType noLoc
126+ (TyApp (TyCon "Rs") (TyApp (TyCon "Download") (tycon n)))
127+ (TyCon "Stream")
128+
129+ alt = Just (var "Media")
130+
108requestDecl :: Global
131requestDecl :: Global
109 -> Prefix
132 -> Prefix
110 -> Name
133 -> Name
111 -> Name
134 -> Name
112 -> [Local]
135 -> [Local]
113− -> Method Solved -> Decl
136+ -> Method Solved
137+ -> Decl
114requestDecl n p api url fs m =
138requestDecl n p api url fs m =
115− -- FIXME: associated Rs type
139+ googleRequestDecl n (tycon n) rs alt p api url fs m
140+ where
141+ rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
142+ maybe unit_tycon (tycon . ref) (_mResponse m)
143+
144+ alt = var . name . Text.unpack . Text.toUpper <$>
145+ (Map.lookup "alt" (_mParameters m) >>= view iDefault)
146+
147+googleRequestDecl :: Global
148+ -> Type
149+ -> InstDecl
150+ -> Maybe Exp
151+ -> Prefix
152+ -> Name
153+ -> Name
154+ -> [Local]
155+ -> Method Solved
156+ -> Decl
157+googleRequestDecl g n assoc alt p api url fs m =
116− InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [tycon n]
158+ InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n]
117− [ response
159+ [ assoc
118 , request
160 , request
119 , requestWithRoute
161 , requestWithRoute
120 ]
162 ]
121 where
163 where
122− response = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
123− maybe unit_tycon (tycon . ref) (_mResponse m)
124−
125 request = funD "request" $
164 request = funD "request" $
126 appFun (var "requestWithRoute") [var "defReq", var url]
165 appFun (var "requestWithRoute") [var "defReq", var url]
127
166
@@ -130,7 +169,7 @@ requestDecl n p api url fs m =
130 match = Match noLoc (name "requestWithRoute") pats Nothing rhs decls
169 match = Match noLoc (name "requestWithRoute") pats Nothing rhs decls
131
170
132 decls = BDecls
171 decls = BDecls
133− [ patBind noLoc (pvar "go") $
172+ [ patBind noLoc pat $
134 appFun (var "clientWithRoute") $
173 appFun (var "clientWithRoute") $
135 [ ExpTypeSig noLoc (var "Proxy") $
174 [ ExpTypeSig noLoc (var "Proxy") $
136 TyApp (TyCon "Proxy") (TyCon (UnQual api))
175 TyApp (TyCon "Proxy") (TyCon (UnQual api))
@@ -138,8 +177,11 @@ requestDecl n p api url fs m =
138 , var "u"
177 , var "u"
139 ]
178 ]
140 ]
179 ]
180+ where
181+ pat | _mSupportsMediaDownload m = PInfixApp (pvar "go") (UnQual (sym ":<|>")) PWildCard
182+ | otherwise = pvar "go"
141
183
142− rhs = UnGuardedRhs $ appFun (var "go") (map go fs)
184+ rhs = UnGuardedRhs $ appFun (var "go") (map go fs ++ maybeToList alt)
143 where
185 where
144 go l | Just p <- Map.lookup l ps
186 go l | Just p <- Map.lookup l ps
145 , _pLocation p == Query
187 , _pLocation p == Query
@@ -150,7 +192,7 @@ requestDecl n p api url fs m =
150 v = var . fname p
192 v = var . fname p
151
193
152 pats = [pvar "r", pvar "u", prec]
194 pats = [pvar "r", pvar "u", prec]
153− prec = PRec (UnQual (dname n)) [PFieldWildcard]
195+ prec = PRec (UnQual (dname g)) [PFieldWildcard]
154
196
155jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
197jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
156jsonDecls g p (Map.toList -> rs) = [from, to]
198jsonDecls g p (Map.toList -> rs) = [from, to]
@@ -342,7 +384,7 @@ externalLit = \case
342 Int32 -> TyCon "Int32"
384 Int32 -> TyCon "Int32"
343 Int64 -> TyCon "Int64"
385 Int64 -> TyCon "Int64"
344
386
345− Alt -> TyCon "Alt"
387+ Alt t -> TyCon (unqual (Text.unpack t))
346 Key -> TyCon "Key"
388 Key -> TyCon "Key"
347 OAuthToken -> TyCon "OAuthToken"
389 OAuthToken -> TyCon "OAuthToken"
348 Body -> TyCon "Body"
390 Body -> TyCon "Body"
@@ -362,7 +404,7 @@ internalLit = \case
362 Int32 -> TyCon "Int32"
404 Int32 -> TyCon "Int32"
363 Int64 -> TyCon "Int64"
405 Int64 -> TyCon "Int64"
364
406
365− Alt -> TyCon "Alt"
407+ Alt t -> TyCon (unqual (Text.unpack t))
366 Key -> TyCon "Key"
408 Key -> TyCon "Key"
367 OAuthToken -> TyCon "OAuthToken"
409 OAuthToken -> TyCon "OAuthToken"
368 Body -> TyCon "Body"
410 Body -> TyCon "Body"
gen/src/Gen/Types/Schema.hs+1−1
@@ -189,7 +189,7 @@ data Lit
189 | Time
189 | Time
190 -- Core types.
190 -- Core types.
191 | Body
191 | Body
192− | Alt
192+ | Alt Text
193 | Key
193 | Key
194 | OAuthToken
194 | OAuthToken
195 deriving (Eq, Show)
195 deriving (Eq, Show)