8399a3c · gogol · git.iko.soy

git.iko.soy/gogol

Adding ghetto alt

commit8399a3c3b59482a229521608685ae67849102a02 authorBrendan Hay <brendan.g.hay@gmail.com> dateThu 1 Oct 2015, 15:36 (11 years ago) parent6406925

5 files changed+124−76

compare with develop

unifiedsplit

gen/src/Gen/AST/Flatten.hs+13−10 gen/src/Gen/AST/Render.hs+32−29 gen/src/Gen/AST/Solve.hs+8−8 gen/src/Gen/Syntax.hs+70−28 gen/src/Gen/Types/Schema.hs+1−1

gen/src/Gen/AST/Flatten.hs+13−10

@@ -29,6 +29,7 @@ import Control.Monad.Except

2929import qualified Data.HashMap.Strict as Map

3030import Data.Maybe

3131import Data.Semigroup ((<>))

32+import qualified Data.Text as Text

3233import Gen.Formatting

3334import Gen.Types

3435import Prelude hiding (sum)

@@ -81,11 +82,13 @@ schema g ml (Fix f) = go f >>= insert this

8182 Obj Nothing <$> Map.traverseWithKey (localSchema this) ps

8283

8384globalParam :: Local -> Param (Fix Schema) -> AST (Param Global)

84−globalParam l = case l of

85− "alt" -> overrideParam l Alt

86− "key" -> overrideParam l Key

87− "oauth_token" -> overrideParam l OAuthToken

88− _ -> localParam "" l

85+globalParam l p = ($ p) $ case l of

86+ "alt" -> overrideParam l (Alt alt)

87+ "key" -> overrideParam l Key

88+ "oauth_token" -> overrideParam l OAuthToken

89+ _ -> localParam "" l

90+ where

91+ alt = Text.toUpper (fromMaybe "JSON" (p ^. iDefault))

8992

9093overrideParam :: Local -> Lit -> Param (Fix Schema) -> AST (Param Global)

9194overrideParam l v p =

@@ -121,15 +124,14 @@ method qs suf m@Method {..} = do

121124

122125 b <- body typ

123126

124− let params = ps <> qs

125− fields = b (upload (Map.map _pParam params))

127+ let params = ps <> qs

128+ fields = Map.delete "alt" $ b (upload (Map.map _pParam params))

126129

127130 void $ insert typ (SObj schemaInfo (Obj Nothing fields))

128131 pure $! m { _mParameters = params }

129132 where

130133 schemaInfo = emptyInfo { _iDescription = _mDescription }

131−

132− bodyInfo = requiredInfo { _iDescription = Just "Multipart request metadata." }

134+ bodyInfo = requiredInfo { _iDescription = Just "Multipart request metadata." }

133135

134136 body p = case _mRequest of

135137 Nothing -> pure id

@@ -138,11 +140,12 @@ method qs suf m@Method {..} = do

138140 g <- localSchema p f (Fix (SRef bodyInfo x))

139141 pure (Map.insert f g)

140142

143+ -- FIXME: Add maxSize to media field description.

141144 upload

142145 | _mSupportsMediaUpload = Map.insert "media" "Body"

143146 | otherwise = id

144147

145− download = id

148+ -- download = id

146149

147150 -- media

148151 -- insert 'media' property of type 'Body'

gen/src/Gen/AST/Render.hs+32−29

@@ -90,35 +90,6 @@ renderSchema s = go (_schema s)

9090 "' with the minimum fields required to make a request.\n")

9191 k

9292

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−

12293renderAPI :: Service Solved -> AST API

12394renderAPI s = do

12495 rs <- traverse (renderResource s resourceNS "Resource")

@@ -148,6 +119,38 @@ renderAPI s = do

148119 "@ of the " % stext % ".")

149120 (s ^. dVersion) (s ^. dTitle)

150121

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+

151154data PP

152155 = Indent

153156 | Print

gen/src/Gen/AST/Solve.hs+8−8

@@ -113,15 +113,15 @@ getDerive g = loc "getDerive" g $ memo derived g go

113113 SObj _ (Obj _ ps) -> foldM props base (Map.elems ps)

114114

115115 literal = \case

116− Text -> base <> [DOrd, DIsString]

117− Bool -> enum

118− Time -> base

119− Date -> base

120− Body -> base

121− Alt -> base

122− Key -> base

116+ Text -> base <> [DOrd, DIsString]

117+ Bool -> enum

118+ Time -> base

119+ Date -> base

120+ Body -> base

121+ Alt _ -> base

122+ Key -> base

123123 -- FIXME: Add numeric cases

124− _ -> [DNum, DIntegral, DReal] <> enum

124+ _ -> [DNum, DIntegral, DReal] <> enum

125125

126126 props ds x = intersect ds <$> getDerive x

127127

gen/src/Gen/Syntax.hs+70−28

@@ -49,12 +49,16 @@ apiAlias n ls = TypeDecl noLoc n [] alias

4949

5050-- type Method = :> ...

5151verbAlias :: 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

5355 where

54− alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) verb

56+ rest = alias verb (path ++ qry params ++ media)

57+ download = TyInfix rest (UnQual (sym ":<|>")) $

58+ alias (TyApp (TyApp meth octet) (TyCon "Stream"))

59+ (path ++ qry (Map.delete "alt" (_mParameters m)) ++ [alt] ++ media)

5560

56− -- FIXME: rather than using 'terminal' to get the terminal type,

57− -- write a custom 'Link' for servant to specify required params.

61+ alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r)

5862

5963 path :: [Type]

6064 path = map match

@@ -73,8 +77,8 @@ verbAlias n m = TypeDecl noLoc n [] (alias (path ++ qry ++ media))

7377 | otherwise = sing x

7478

7579 -- FIXME: order by _mParameterOrder

76− qry :: [Type]

77− qry = mapMaybe f (Map.toList params)

80+-- qry :: [Type]

81+ qry = mapMaybe f . Map.toList

7882 where

7983 f (k, x) =

8084 let t = terminalType (_type (_pParam x))

@@ -89,39 +93,74 @@ verbAlias n m = TypeDecl noLoc n [] (alias (path ++ qry ++ media))

8993 media | Just b <- _mRequest m =

9094 let g = ref b

9195 in if _mSupportsMediaUpload m

92− then [TyApp (TyApp (TyCon "Multipart") typ) (parts g)]

93− else [TyApp (TyApp (TyCon "ReqBody") typ) (tycon g)]

96+ then [TyApp (TyApp (TyCon "Multipart") json) (parts g)]

97+ else [TyApp (TyApp (TyCon "ReqBody") json) (tycon g)]

9498 | otherwise = []

9599 where

96− parts g = TyCon (UnQual (name (Text.unpack ("'[" <> global g <> ", Body]"))))

97− typ = TyCon "'[JSON]"

100+ parts g = TyCon . UnQual . name . Text.unpack $

101+ "'[" <> global g <> ", Body]"

98102

99− verb :: Type

100− verb = TyApp (TyApp meth typ) res

101− where

102− meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mHttpMethod m)

103− typ = TyCon "'[JSON]"

104− res = maybe (TyCon "()") (tycon . ref) (_mResponse m)

103+ verb = TyApp (TyApp meth json) $

104+ maybe (TyCon "()") (tycon . ref) (_mResponse m)

105+

106+ meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mHttpMethod m)

107+

108+ octet = TyCon "'[OctetStream]"

109+ json = TyCon "'[JSON]"

110+

111+ alt = TyApp (TyApp (TyCon "QueryParam") (sing "alt")) (TyCon "Media")

105112

106113 params = _mParameters m

107114

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+

108131requestDecl :: Global

109132 -> Prefix

110133 -> Name

111134 -> Name

112135 -> [Local]

113− -> Method Solved -> Decl

136+ -> Method Solved

137+ -> Decl

114138requestDecl n p api url fs m =

115− -- FIXME: associated Rs type

116− InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [tycon n]

117− [ response

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 =

158+ InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n]

159+ [ assoc

118160 , request

119161 , requestWithRoute

120162 ]

121163 where

122− response = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $

123− maybe unit_tycon (tycon . ref) (_mResponse m)

124−

125164 request = funD "request" $

126165 appFun (var "requestWithRoute") [var "defReq", var url]

127166

@@ -130,7 +169,7 @@ requestDecl n p api url fs m =

130169 match = Match noLoc (name "requestWithRoute") pats Nothing rhs decls

131170

132171 decls = BDecls

133− [ patBind noLoc (pvar "go") $

172+ [ patBind noLoc pat $

134173 appFun (var "clientWithRoute") $

135174 [ ExpTypeSig noLoc (var "Proxy") $

136175 TyApp (TyCon "Proxy") (TyCon (UnQual api))

@@ -138,8 +177,11 @@ requestDecl n p api url fs m =

138177 , var "u"

139178 ]

140179 ]

180+ where

181+ pat | _mSupportsMediaDownload m = PInfixApp (pvar "go") (UnQual (sym ":<|>")) PWildCard

182+ | otherwise = pvar "go"

141183

142− rhs = UnGuardedRhs $ appFun (var "go") (map go fs)

184+ rhs = UnGuardedRhs $ appFun (var "go") (map go fs ++ maybeToList alt)

143185 where

144186 go l | Just p <- Map.lookup l ps

145187 , _pLocation p == Query

@@ -150,7 +192,7 @@ requestDecl n p api url fs m =

150192 v = var . fname p

151193

152194 pats = [pvar "r", pvar "u", prec]

153− prec = PRec (UnQual (dname n)) [PFieldWildcard]

195+ prec = PRec (UnQual (dname g)) [PFieldWildcard]

154196

155197jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]

156198jsonDecls g p (Map.toList -> rs) = [from, to]

@@ -342,7 +384,7 @@ externalLit = \case

342384 Int32 -> TyCon "Int32"

343385 Int64 -> TyCon "Int64"

344386

345− Alt -> TyCon "Alt"

387+ Alt t -> TyCon (unqual (Text.unpack t))

346388 Key -> TyCon "Key"

347389 OAuthToken -> TyCon "OAuthToken"

348390 Body -> TyCon "Body"

@@ -362,7 +404,7 @@ internalLit = \case

362404 Int32 -> TyCon "Int32"

363405 Int64 -> TyCon "Int64"

364406

365− Alt -> TyCon "Alt"

407+ Alt t -> TyCon (unqual (Text.unpack t))

366408 Key -> TyCon "Key"

367409 OAuthToken -> TyCon "OAuthToken"

368410 Body -> TyCon "Body"

gen/src/Gen/Types/Schema.hs+1−1

@@ -189,7 +189,7 @@ data Lit

189189 | Time

190190 -- Core types.

191191 | Body

192− | Alt

192+ | Alt Text

193193 | Key

194194 | OAuthToken

195195 deriving (Eq, Show)