afab3a3 · gogol · git.iko.soy

gen/src/Gen/AST/Flatten.hs+11−7

compare with develop

unifiedsplit

@@ -38,10 +38,10 @@ import Prelude hiding (sum)

38

39flatten :: Service (Fix Schema) -> AST (Service Global)

40flatten s = do

41− ps <- Map.traverseWithKey globalParam (s ^. dParameters)

41+ ps <- kvTraverseMaybe globalParam (s ^. dParameters)

42 rs <- Map.traverseWithKey (resource ps "Resource") (s ^. dResources)

43 ms <- traverse (method ps "Method") (s ^. dMethods)

44− _ <- Map.traverseWithKey globalSchema (s ^. dSchemas)

44+ _ <- Map.traverseWithKey globalSchema (s ^. dSchemas)

45

46 -- The horror.

47 ss <- use schemas

@@ -110,12 +110,16 @@ schema g ml (Fix f) = go (maybe g (reference g) ml) f >>= uncurry insert

110 format ("Unable to generate name for reserved schema: " % gid % ", " % shown % ", " % gid)

111 g ml p

112

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

113+globalParam :: Local -> Param (Fix Schema) -> AST (Maybe (Param Global))

114globalParam l p = case l of

115− "alt" -> overrideParam l (Alt alt) p

115+ "key" -> pure Nothing

116− "key" -> overrideParam l Key p

116+ "oauth_token" -> pure Nothing

117− "oauth_token" -> overrideParam l OAuthToken (p & pLocation .~ Header)

117+ "prettyPrint" -> pure Nothing

118+ "quotaUser" -> pure Nothing

119+ "fields" -> pure Nothing

120+ "userIp" -> pure Nothing

121+ "alt" -> Just <$> overrideParam l (Alt alt) p

118− _ -> localParam "" l p

122+ _ -> Just <$> localParam "" l p

119 where

123 where

120 alt = alternate $ fromMaybe "JSON" (p ^. iDefault)

124 alt = alternate $ fromMaybe "JSON" (p ^. iDefault)

121

125

gen/src/Gen/AST/Render.hs+17−4

@@ -33,6 +33,7 @@ import Data.Semigroup ((<>))

33import qualified Data.Text as Text

34import qualified Data.Text.Lazy as LText

35import qualified Data.Text.Lazy.Builder as Build

36+import Data.Text.Manipulate

36import Debug.Trace

37import Debug.Trace

37import Gen.AST.Solve (getSolved)

38import Gen.AST.Solve (getSolved)

38import Gen.Formatting

39import Gen.Formatting

@@ -106,13 +107,15 @@ renderAPI s = do

106

107

107 d <- pp Print $ apiAlias alias (map _actAliasName (rs <> ms))

108 d <- pp Print $ apiAlias alias (map _actAliasName (rs <> ms))

108

109

109− API alias d rs ms <$> serviceURL

110+ API alias d rs ms

111+ <$> svc

112+ <*> traverse scp (maybe mempty (Map.toList . scopes) (s ^. dAuth))

110 where

113 where

111 alias = aname (_sCanonicalName s)

114 alias = aname (_sCanonicalName s)

112

115

113 url = name (Text.unpack (urlName s))

116 url = name (Text.unpack (urlName s))

114

117

115− serviceURL = Fun' url (Just (rawHelpText h))

118+ svc = Fun' url (Just (rawHelpText h))

116 <$> pp None (urlSig url)

119 <$> pp None (urlSig url)

117 <*> pp Print (urlDecl s url)

120 <*> pp Print (urlDecl s url)

118 where

121 where

@@ -120,16 +123,26 @@ renderAPI s = do

120 "@ of the " % stext % ". This contains the host and root path used as a starting point for constructing service requests.")

123 "@ of the " % stext % ". This contains the host and root path used as a starting point for constructing service requests.")

121 (s ^. dVersion) (s ^. dTitle)

124 (s ^. dVersion) (s ^. dTitle)

122

125

126+ scp (k, h) = Fun' n (Just h)

127+ <$> pp None (scopeSig n)

128+ <*> pp None (scopeDecl n k)

129+ where

130+ n = name

131+ . Text.unpack

132+ . (<> "Scope")

133+ . toCamel

134+ . last

135+ $ Text.split (== '/') k

136+

123renderMethod :: Service a -> NS -> Suffix -> Method Solved -> AST Action

137renderMethod :: Service a -> NS -> Suffix -> Method Solved -> AST Action

124renderMethod s root suf m@Method {..} = do

138renderMethod s root suf m@Method {..} = do

125 x@Solved {..} <- getSolved typ

139 x@Solved {..} <- getSolved typ

126 Just d <- renderSchema x

140 Just d <- renderSchema x

127

141

128− a <- pp Print $ authDecl _unique _prefix (props _schema)

129 i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m

142 i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m

130 dl <- pp Print $ downloadDecl _unique _prefix alias url (props _schema) m

143 dl <- pp Print $ downloadDecl _unique _prefix alias url (props _schema) m

131

144

132− let is = a : i : [dl | _mSupportsMediaDownload]

145+ let is = i : [dl | _mSupportsMediaDownload]

133

146

134 Action _mId _unique (root <> mkNS ns) _mDescription alias

147 Action _mId _unique (root <> mkNS ns) _mDescription alias

135 <$> pp Print (verbAlias alias m)

148 <$> pp Print (verbAlias alias m)

gen/src/Gen/AST/Solve.hs−2

@@ -135,8 +135,6 @@ getDerive g = loc "getDerive" g $ memo derived g go

135 Date -> DRead : base

136 Body -> []

137 Alt _ -> DRead : base

138− Key -> DRead : base

139− OAuthToken -> DRead : base

140 JSONValue -> DRead : base

138 JSONValue -> DRead : base

141 -- FIXME: Add numeric cases

139 -- FIXME: Add numeric cases

142 _ -> [DRead, DNum, DIntegral, DReal] <> enum

140 _ -> [DRead, DNum, DIntegral, DReal] <> enum

gen/src/Gen/Syntax.hs+16−27

@@ -34,16 +34,25 @@ import Language.Haskell.Exts.SrcLoc

34import Language.Haskell.Exts.Syntax hiding (Alt, Int, Lit)

35

36urlSig :: Name -> Decl

37−urlSig n = TypeSig noLoc [n] (TyCon "RequestBuilder")

37+urlSig n = TypeSig noLoc [n] (TyCon "Service")

38

39urlDecl :: Service a -> Name -> Decl

40urlDecl s n = sfun noLoc n [] (UnGuardedRhs rhs) noBinds

41 where

42− rhs = appFun (var "defaultRequest")

42+ rhs = appFun (var "defaultService")

43− [ str (s ^. dRootUrl)

43+ [ app (var "ServiceId") (str (s ^. dId))

44+ , str . stripSuffix "/" $ stripPrefix "https://" (s ^. dRootUrl)

44 , str (s ^. dServicePath)

45 , str (s ^. dServicePath)

45 ]

46 ]

46

47

48+scopeSig :: Name -> Decl

49+scopeSig n = TypeSig noLoc [n] (TyCon "OAuthScope")

50+

51+scopeDecl :: Name -> Text -> Decl

52+scopeDecl n s = sfun noLoc n [] (UnGuardedRhs rhs) noBinds

53+ where

54+ rhs = app (var "OAuthScope") (str s)

55+

47 -- type API = :<|> ...

56 -- type API = :<|> ...

48apiAlias :: Name -> [Name] -> Decl

57apiAlias :: Name -> [Name] -> Decl

49apiAlias n ls = TypeDecl noLoc n [] alias

58apiAlias n ls = TypeDecl noLoc n [] alias

@@ -97,8 +106,6 @@ verbAlias n m

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

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

98 n = sing (local k)

107 n = sing (local k)

99 in case _pLocation x of

108 in case _pLocation x of

100− Header | local k == "oauth_token"

101− -> Just $ TyApp (TyApp (TyCon "Header") (sing "Authorization")) t

102 Query | x ^. iRepeated

109 Query | x ^. iRepeated

103 -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t

110 -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t

104 Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t

111 Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t

@@ -188,21 +195,18 @@ googleRequestDecl g n assoc alt p api url fields m pat prec =

188 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n]

195 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n]

189 [ assoc

196 [ assoc

190 , request

197 , request

191− , requestWith

192 ]

198 ]

193 where

199 where

194− request = funD "request" $ app (var "requestWith") (var url)

195−

196− requestWith = InsDecl (FunBind [match])

200+ request = InsDecl (FunBind [match])

197 where

201 where

198− match = Match noLoc (name "requestWith") pats Nothing rhs decls

202+ match = Match noLoc (name "requestClient") [prec] Nothing rhs decls

199

203

200 decls = BDecls

204 decls = BDecls

201 [ patBind noLoc pat $

205 [ patBind noLoc pat $

202 appFun (var "clientBuild") $

206 appFun (var "clientBuild") $

203 [ ExpTypeSig noLoc (var "Proxy") $

207 [ ExpTypeSig noLoc (var "Proxy") $

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

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

205− , var "rq"

209+ , var "mempty"

206 ]

210 ]

207 ]

211 ]

208

212

@@ -210,6 +214,7 @@ googleRequestDecl g n assoc alt p api url fields m pat prec =

210 ++ maybeToList (app (var "Just") <$> alt)

214 ++ maybeToList (app (var "Just") <$> alt)

211 ++ maybeToList (go <$> rq)

215 ++ maybeToList (go <$> rq)

212 ++ maybeToList (go <$> pay)

216 ++ maybeToList (go <$> pay)

217+ ++ [var url]

213 where

218 where

214 go l = case Map.lookup l ps of

219 go l = case Map.lookup l ps of

215 Just p | _pLocation p == Query

220 Just p | _pLocation p == Query

@@ -240,18 +245,6 @@ googleRequestDecl g n assoc alt p api url fields m pat prec =

240 . nub

245 . nub

241 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m

246 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m

242

247

243− pats = [pvar "rq", prec]

244−

245−authDecl :: Global -> Prefix -> [Local] -> Decl

246−authDecl g p fs = InstDecl noLoc Nothing [] [] (unqual "GoogleAuth") [tycon g]

247− [ method "_AuthKey" "key"

248− , method "_AuthToken" "oauth_token"

249− ]

250− where

251− method l f

252− | f `elem` fs = funD l (infixApp (var (lname p f)) "." (var "_Just"))

253− | otherwise = funD l (app (var "const") (var "pure"))

254−

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

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

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

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

257 where

250 where

@@ -458,8 +451,6 @@ externalLit = \case

458 Int64 -> TyCon "Int64"

451 Int64 -> TyCon "Int64"

459

452

460 Alt t -> TyCon (unqual (Text.unpack t))

453 Alt t -> TyCon (unqual (Text.unpack t))

461− Key -> TyCon "AuthKey"

462− OAuthToken -> TyCon "OAuthToken"

463 Body -> TyCon "Stream"

454 Body -> TyCon "Stream"

464 JSONValue -> TyCon "JSONValue"

455 JSONValue -> TyCon "JSONValue"

465

456

@@ -480,8 +471,6 @@ internalLit = \case

480 Int64 -> TyCon "Int64"

471 Int64 -> TyCon "Int64"

481

472

482 Alt t -> TyCon (unqual (Text.unpack t))

473 Alt t -> TyCon (unqual (Text.unpack t))

483− Key -> TyCon "AuthKey"

484− OAuthToken -> TyCon "OAuthToken"

485 Body -> TyCon "Stream"

474 Body -> TyCon "Stream"

486 JSONValue -> TyCon "JSONValue"

475 JSONValue -> TyCon "JSONValue"

487

476

gen/src/Gen/Types.hs+1

@@ -256,6 +256,7 @@ instance ToJSON Library where

256 , "documentationLink" .= (l ^. dDocumentationLink)

257 , "labels" .= (l ^. dLabels)

258 , "features" .= (l ^. dFeatures)

259+ , "scopes" .= (l ^. dAuth)

259

260

260 -- API

261 -- API

261 , "api" .= (l ^. lAPI)

262 , "api" .= (l ^. lAPI)

gen/src/Gen/Types/Data.hs+2

@@ -121,6 +121,7 @@ data API = API

121 , _apiResources :: [Action]

122 , _apiMethods :: [Action]

123 , _apiURL :: Fun

124+ , _apuScopes :: [Fun]

124 }

125 }

125

126

126instance ToJSON API where

127instance ToJSON API where

@@ -131,4 +132,5 @@ instance ToJSON API where

131 , "resources" .= sortOn _actId _apiResources

132 , "resources" .= sortOn _actId _apiResources

132 , "methods" .= sortOn _actId _apiMethods

133 , "methods" .= sortOn _actId _apiMethods

133 , "url" .= _apiURL

134 , "url" .= _apiURL

135+ , "scopes" .= _apuScopes

134 ]

136 ]

gen/src/Gen/Types/Id.hs+2−4

@@ -190,7 +190,7 @@ extractPath x = either (error . err) id $ A.parseOnly path x

190 where

191 err e = "Error parsing \"" <> Text.unpack x <> "\", " <> e

192

193− path = A.many1 (seg <|> repeat <|> var) <* A.endOfInput

193+ path = A.many1 (seg <|> repeat <|> var') <* A.endOfInput

194

195 seg = fmap Left $

196 optional (A.char '/') *> A.takeWhile1 (A.notInClass "/{+*}")

@@ -200,7 +200,7 @@ extractPath x = either (error . err) id $ A.parseOnly path x

200 (,Nothing) <$> fmap Local (A.takeWhile1 (/= '*'))

201 <* A.string "*}"

202

203− var = fmap Right $ do

203+ var' = fmap Right $ do

204 void $ optional (A.char '/') *> A.char '{' *> optional (A.char '+')

205 (,) <$> fmap Local (A.takeWhile1 (A.notInClass "/{+*}:"))

206 <* A.char '}'

@@ -222,8 +222,6 @@ orderParams f xs ys = orderBy f zs (del zs [] ++ global)

222 , "prettyPrint"

223 , "userIp"

224 , "fields"

225− , "key"

226− , "oauth_token"

227 , "alt"

225 , "alt"

228 ]

226 ]

229

227

gen/src/Gen/Types/Schema.hs+2−5

@@ -54,7 +54,6 @@ newtype Fix f = Fix (f (Fix f))

54data Location

55 = Query

56 | Path

57− | Header

58 deriving (Eq, Show)

57 deriving (Eq, Show)

59

58

60deriveJSON options ''Location

59deriveJSON options ''Location

@@ -203,8 +202,6 @@ data Lit

203 | Body

202 | Body

204 | JSONValue

203 | JSONValue

205 | Alt Text

204 | Alt Text

206− | Key

207− | OAuthToken

208 deriving (Eq, Show)

205 deriving (Eq, Show)

209

206

210instance FromJSON Lit where

207instance FromJSON Lit where

@@ -331,7 +328,7 @@ instance FromJSON a => FromJSON (Resource a) where

331 <*> (o .:? "methods" .!= mempty <&> keyless)

328 <*> (o .:? "methods" .!= mempty <&> keyless)

332

329

333newtype OAuth2 = OAuth2 { scopes :: Map Text Help }

330newtype OAuth2 = OAuth2 { scopes :: Map Text Help }

334− deriving (Eq, Show)

331+ deriving (Eq, Show, ToJSON)

335

332

336instance FromJSON OAuth2 where

333instance FromJSON OAuth2 where

337 parseJSON = withObject "oauth2" $ \x -> do

334 parseJSON = withObject "oauth2" $ \x -> do

@@ -436,4 +433,4 @@ instance HasDescription (Service a) a where

436 description = sDescription

433 description = sDescription

437

434

438urlName :: Service a -> Text

435urlName :: Service a -> Text

439−urlName = (<> "Request") . lowerHead . _sCanonicalName

436+urlName = (<> "Service") . toCamel . _sCanonicalName

gen/template/toc.ede+4−1

@@ -12,8 +12,11 @@

12-- /See:/ <{{ documentationLink }} {{ title }} Reference>

13module {{ moduleName }}

14 (

15+ -- * Service Configuration

16+ {{ api.url.name }}

17+

15 -- * API Declaration

18 -- * API Declaration

16− {{ api.aliasName }}

19+ , {{ api.aliasName }}

17 {% for action in api.methods %}

20 {% for action in api.methods %}

18 {% if action.first %}

21 {% if action.first %}

19

22

gen/template/types.ede+16−1

@@ -9,8 +9,15 @@

9--

10module {{ moduleName }}

11 (

12− -- * Service Request

12+ -- * Service Configuration

13 {{ api.url.name }}

14+ {% for scope in api.scopes %}

15+ {% if scope.first %}

16+

17+ -- * OAuth Scopes

18+ {% endif %}

19+ , {{ scope.value.name }}

20+ {% endfor %}

14 {% for schema in schemas %}

21 {% for schema in schemas %}

15 {% case schema.value.type %}

22 {% case schema.value.type %}

16 {% when "prod" %}

23 {% when "prod" %}

@@ -38,3 +45,11 @@ import {{ import.value }}

38{% endif %}

45{% endif %}

39{{ api.url.sig }}

46{{ api.url.sig }}

40{{ api.url.decl }}

47{{ api.url.decl }}

48+{% for scope in api.scopes %}

49+

50+{% if scope.value.help %}

51+{{ scope.value.help }}

52+{% endif %}

53+{{ scope.value.sig }}

54+{{ scope.value.decl }}

55+{% endfor %}