20c45ba · gogol · git.iko.soy

git.iko.soy/gogol

Oh lord.

commit20c45ba6005774a897d4e64048908c613a5f66dc authorBrendan Hay <brendan.g.hay@gmail.com> dateThu 1 Oct 2015, 18:15 (11 years ago) parentec605e4

4 files changed+40−25

compare with develop

unifiedsplit

gen/src/Gen/AST/Flatten.hs+1−1 gen/src/Gen/AST/Solve.hs+16−13 gen/src/Gen/Syntax.hs+19−10 gen/src/Gen/Types/Schema.hs+4−1

gen/src/Gen/AST/Flatten.hs+1−1

@@ -88,7 +88,7 @@ globalParam l p = ($ p) $ case l of

8888 "oauth_token" -> overrideParam l OAuthToken

8989 _ -> localParam "" l

9090 where

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

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

9292

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

9494overrideParam l v p =

gen/src/Gen/AST/Solve.hs+16−13

@@ -87,19 +87,22 @@ getSchema g = do

8787getType :: Global -> AST TType

8888getType g = loc "getType" g $ memo typed g go

8989 where

90− go s = fmap (may s) $

91− case s of

92− SAny {} -> pure (TType "JSONValue")

93− SRef _ r -> getType (ref r)

94− --- FIXME: add natural/numeric manipulations

95− SLit _ l -> pure (TLit l)

96− SEnm {} -> pure (TType g)

97− SArr _ (Arr e) -> TList <$> getType e

98− SObj {} -> pure (TType g)

99−

100− may s | required s = id

101− | defaulted s = id

102− | otherwise = TMaybe

90+ go s = case s of

91+ SAny {} -> may (TType "JSONValue")

92+ SRef _ r -> unmay <$> getType (ref r)

93+ --- FIXME: add natural/numeric manipulations

94+ SLit _ l -> may (TLit l)

95+ SEnm {} -> may (TType g)

96+ SArr _ (Arr e) -> (TList <$> (getType e)) >>= may

97+ SObj {} -> may (TType g)

98+ where

99+ may | required s = pure

100+ | defaulted s = pure

101+ | otherwise = pure . TMaybe

102+

103+ unmay (TMaybe x)

104+ | required s = x

105+ unmay x = x

103106

104107getDerive :: Global -> AST [Derive]

105108getDerive g = loc "getDerive" g $ memo derived g go

gen/src/Gen/Syntax.hs+19−10

@@ -17,6 +17,7 @@ import Control.Lens hiding (iso, mapping, op, pre,

1717import Data.Foldable (find, foldl', foldr')

1818import Data.Hashable

1919import qualified Data.HashMap.Strict as Map

20+import Data.List (delete)

2021import Data.Maybe

2122import Data.Maybe

2223import Data.Semigroup ((<>))

@@ -93,20 +94,19 @@ verbAlias n m

9394 media | Just b <- _mRequest m =

9495 let g = ref b

9596 in if _mSupportsMediaUpload m

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

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

97+ then [TyApp (TyApp (TyApp (TyCon "MultipartRelated") json)

98+ (tycon g))

99+ (TyCon "Body")]

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

98101 | otherwise = []

99− where

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

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

102102

103103 verb = TyApp (TyApp meth json) $

104104 maybe (TyCon "()") (tycon . ref) (_mResponse m)

105105

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

107107

108− octet = TyCon "'[OctetStream]"

109− json = TyCon "'[JSON]"

108+ octet = tylist ["OctetStream"]

109+ json = tylist ["JSON"]

110110

111111 alt = TyApp (TyApp (TyCon "QueryParam") (sing "alt")) (TyCon "Media")

112112

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

141141 rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $

142142 maybe unit_tycon (tycon . ref) (_mResponse m)

143143

144− alt = var . name . Text.unpack . Text.toUpper <$>

144+ alt = var . name . Text.unpack . alternate <$>

145145 (Map.lookup "alt" (_mParameters m) >>= view iDefault)

146146

147147googleRequestDecl :: Global

@@ -181,7 +181,9 @@ googleRequestDecl g n assoc alt p api url fs m =

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

182182 | otherwise = pvar "go"

183183

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

184+ rhs = UnGuardedRhs . appFun (var "go") $ map go fs'

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

186+ ++ maybeToList (go <$> rq)

185187 where

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

187189 , _pLocation p == Query

@@ -191,6 +193,9 @@ googleRequestDecl g n assoc alt p api url fs m =

191193 ps = _mParameters m

192194 v = var . fname p

193195

196+ (fs', rq) | Just r <- _mRequest m = let x = localise (ref r) in (delete x fs, Just x)

197+ | otherwise = (fs, Nothing)

198+

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

195200 prec = PRec (UnQual (dname g)) [PFieldWildcard]

196201

@@ -201,7 +206,7 @@ authDecl g p fs = InstDecl noLoc Nothing [] [] (unqual "GoogleAuth") [tycon g]

201206 ]

202207 where

203208 method l f

204− | f `elem` fs = funD l (var (lname p f))

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

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

206211

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

@@ -444,6 +449,10 @@ strict = TyBang BangedTy . \case

444449sing :: Text -> Type

445450sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""

446451

452+tylist :: [Text] -> Type

453+tylist xs = TyCon . UnQual . name . Text.unpack $

454+ "'[" <> Text.intercalate ", " xs <> "]"

455+

447456tycon :: Global -> Type

448457tycon = TyCon . UnQual . dname

449458

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

@@ -93,6 +93,9 @@ defaulted = isJust . view iDefault

9393required = view iRequired

9494parameter s = required s && not (defaulted s)

9595

96+alternate :: Text -> Text

97+alternate = mappend "Alt" . Text.toUpper

98+

9699emptyInfo :: Info

97100emptyInfo = Info

98101 { _iId = Nothing

@@ -107,7 +110,7 @@ emptyInfo = Info

107110 }

108111

109112requiredInfo :: Info

110−requiredInfo = emptyInfo & iRequired .~ True

113+requiredInfo = setRequired emptyInfo

111114

112115setRequired :: HasInfo a => a -> a

113116setRequired = iRequired .~ True