fff7443 · gogol · git.iko.soy

git.iko.soy/gogol

on develop help sign in

Rendering GoogleRequest instances

fff7443Brendan Hay11 years ago

gen/src/Gen/AST.hs+13−6

compare with develop

unifiedsplit

@@ -110,13 +110,20 @@ render svc = do

110 s <- solve i

111 Just d <- typ s

112 fmap (k,) $

113− Action k (actionNS svc p l) (_mDescription m)

113+ Action k (apretty p l) (actionNS svc p l) (_mDescription m)

114 <$> pp Print (verbAlias svc k m)

115+ <*> reset m s d

116+

117+ reset m s = \case

115− <*> pure (reset d)

118+ d@Sum {} -> pure d

116−

117− reset = \case

118− Prod n' h r c ls _ -> Prod n' h r c ls []

119+ Prod n' h r c ls _ ->

119− d -> d

120+ Prod n' h r c ls . (:[]) <$> pp Print

121+ (requestDecl (_ident s) (_prefix s) (fields (_schema s))

122+ (fmap Free (_mResponse m)))

123+

124+ fields = \case

125+ Obj _ rs -> Map.keys rs

126+ _ -> mempty

120

127

121solveAll :: Flattened -> AST Typed

128solveAll :: Flattened -> AST Typed

122solveAll svc = do

129solveAll svc = do

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

@@ -45,6 +45,9 @@ verbAlias s n m = TypeDecl noLoc n [] alias

45 where

46 alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) verb (path ++ qry)

48+ -- FIXME: rather than using 'terminal' to get the terminal type,

49+ -- write a custom 'Link' for servant to specify required params.

50+

48 path :: [Type]

51 path :: [Type]

49 path = map match

52 path = map match

50 . filter (not . Text.null)

53 . filter (not . Text.null)

@@ -59,7 +62,7 @@ verbAlias s n m = TypeDecl noLoc n [] alias

59 , _prmLocation k == Path

62 , _prmLocation k == Path

60 = TyApp (TyApp (tycon "Capture")

63 = TyApp (TyApp (tycon "Capture")

61 (sing (Text.init t)))

64 (sing (Text.init t)))

62− (external (_type (_prmSchema k)))

65+ (terminalType (_type (_prmSchema k)))

63 | otherwise = sing x

66 | otherwise = sing x

65 -- FIXME: order by _mParameterOrder

68 -- FIXME: order by _mParameterOrder

@@ -67,11 +70,12 @@ verbAlias s n m = TypeDecl noLoc n [] alias

67 qry = mapMaybe f (Map.toList params)

70 qry = mapMaybe f (Map.toList params)

68 where

71 where

69 f (k, x) =

72 f (k, x) =

70− -- FIXME: types, many/repeated

71− let t = external (_type (_prmSchema x))

73+ let t = terminalType (_type (_prmSchema x))

72 n = sing (local k)

74 n = sing (local k)

73 in case _prmLocation x of

75 in case _prmLocation x of

74 Query -> Just $ TyApp (TyApp (tycon "QueryParam") n) t

76 Query -> Just $ TyApp (TyApp (tycon "QueryParam") n) t

77+ Query | _prmRepeated x

78+ -> Just $ TyApp (TyApp (tycon "QueryParams") n) t

75 Path -> Nothing

79 Path -> Nothing

77 params = _mParameters m

81 params = _mParameters m

@@ -83,6 +87,35 @@ verbAlias s n m = TypeDecl noLoc n [] alias

83 typ = tycon "'[JSON]"

87 typ = tycon "'[JSON]"

84 res = maybe (tycon "()") (tycon . Free) (_mResponse m)

88 res = maybe (tycon "()") (tycon . Free) (_mResponse m)

90+requestDecl :: Id -> Pre -> [Local] -> Maybe Id -> Decl

91+requestDecl n p fs r =

92+ -- FIXME: associated Rs type

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

94+ [ response

95+ , request

96+ , requestWithRoute

97+ ]

98+ where

99+ response = InsType noLoc (TyApp (tycon "Rs") (tycon n)) $

100+ maybe unit_tycon tycon r

101+

102+ request = funD "request" $

103+ appFun (var "requestWithRoute") [var "defReq", var "serviceURL"]

104+

105+ requestWithRoute =

106+ InsDecl (FunBind [match "requestWithRoute" e])

107+ where

108+ e = appFun (var "clientWithRoute") $

109+ [ ExpTypeSig noLoc (var "Proxy") (TyApp (tycon "Proxy") (tycon n))

110+ , var "r"

111+ , var "u"

112+ ] ++ map (var . fname p) fs

113+

114+ match f e = Match noLoc (name f) pats Nothing (UnGuardedRhs e) noBinds

115+

116+ pats = [prec, pvar "r", pvar "u"]

117+ prec = PRec (UnQual (dname n)) [PFieldWildcard]

118+

86jsonDecls :: Id -> Pre -> Map Local Solved -> [Decl]

119jsonDecls :: Id -> Pre -> Map Local Solved -> [Decl]

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

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

88 where

121 where

@@ -170,8 +203,8 @@ conDecl n p rs = QualConDecl noLoc [] [] body

170 where

203 where

171 body = case Map.toList rs of

204 body = case Map.toList rs of

172 [] -> ConDecl n []

205 [] -> ConDecl n []

173− [x] -> RecDecl n [field internal x]

206+ [x] -> RecDecl n [field internalType x]

174− xs -> RecDecl n (map (field (strict . internal)) xs)

207+ xs -> RecDecl n (map (field (strict . internalType)) xs)

175

208

176 field f (l, v) = ([fname p l], f (_type v))

209 field f (l, v) = ([fname p l], f (_type v))

177

210

@@ -206,7 +239,7 @@ fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs

206lensSig :: Id -> Pre -> Local -> Solved -> Decl

239lensSig :: Id -> Pre -> Local -> Solved -> Decl

207lensSig n p l s = TypeSig noLoc [lname p l] $

240lensSig n p l s = TypeSig noLoc [lname p l] $

208 TyApp (TyApp (tycon "Lens'") (tycon n))

241 TyApp (TyApp (tycon "Lens'") (tycon n))

209− (external (_type s))

242+ (externalType (_type s))

210

243

211lensDecl :: Pre -> Local -> Solved -> Decl

244lensDecl :: Pre -> Local -> Solved -> Decl

212lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds

245lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds

@@ -220,7 +253,7 @@ lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds

220 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))

253 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))

221

254

222parameters :: [Solved] -> [Type]

255parameters :: [Solved] -> [Type]

223−parameters = map (external . _type) . filter (view required)

256+parameters = map (externalType . _type) . filter (view required)

224

257

225def :: Solved -> Maybe Exp

258def :: Solved -> Maybe Exp

226def s

259def s

@@ -236,20 +269,32 @@ def s

236

269

237 lit = var . name . Text.unpack

270 lit = var . name . Text.unpack

238

271

239−external, internal :: TType -> Type

272+terminalType :: TType -> Type

240−external = internal . \case

273+terminalType = internalType . go

241− TMaybe t@TList {} -> t

274+ where

242− t -> t

275+ go (TMaybe x) = x

243−

276+ go (TList x) = x

244−internal = \case

277+ go x = x

278+

279+externalType :: TType -> Type

280+externalType = \case

281+ TType r -> tycon r

282+ TMaybe t@TList {} -> externalType t

283+ TMaybe t -> TyApp (tycon "Maybe") (externalType t)

284+ TEither a b -> TyApp (TyApp (tycon "Either") (externalType a)) (externalType b)

285+ TList t -> TyList (externalType t)

286+ TLit l -> externalLit l

287+

288+internalType :: TType -> Type

289+internalType = \case

245 TType r -> tycon r

290 TType r -> tycon r

246− TMaybe t -> TyApp (tycon "Maybe") (internal t)

291+ TMaybe t -> TyApp (tycon "Maybe") (internalType t)

247− TEither a b -> TyApp (TyApp (tycon "Either") (internal a)) (internal b)

292+ TEither a b -> TyApp (TyApp (tycon "Either") (internalType a)) (internalType b)

248− TList t -> TyList (internal t)

293+ TList t -> TyList (internalType t)

249− TLit l -> literal l

294+ TLit l -> internalLit l

250

295

251−literal :: Lit -> Type

296+externalLit :: Lit -> Type

252−literal = \case

297+externalLit = \case

253 Text -> tycon "Text"

298 Text -> tycon "Text"

254 Bool -> tycon "Bool"

299 Bool -> tycon "Bool"

255 Time -> tycon "UTCTime"

300 Time -> tycon "UTCTime"

@@ -263,6 +308,21 @@ literal = \case

263 Int32 -> tycon "Int32"

308 Int32 -> tycon "Int32"

264 Int64 -> tycon "Int64"

309 Int64 -> tycon "Int64"

265

310

311+internalLit :: Lit -> Type

312+internalLit = \case

313+ Text -> tycon "Text"

314+ Bool -> tycon "Bool"

315+ Time -> tycon "UTCTime"

316+ Date -> tycon "UTCTime"

317+ Nat -> tycon "Nat"

318+ Float -> tycon "Float"

319+ Double -> tycon "Double"

320+ Byte -> tycon "Word8"

321+ UInt32 -> tycon "Word32"

322+ UInt64 -> tycon "Word64"

323+ Int32 -> tycon "Int32"

324+ Int64 -> tycon "Int64"

325+

266mapping :: TType -> Exp -> Exp

326mapping :: TType -> Exp -> Exp

267mapping t e = infixE e "." (go t)

327mapping t e = infixE e "." (go t)

268 where

328 where

@@ -277,6 +337,7 @@ mapping t e = infixE e "." (go t)

277iso :: TType -> Maybe Exp

337iso :: TType -> Maybe Exp

278iso = \case

338iso = \case

279 TList {} -> Just (var "_Coerce")

339 TList {} -> Just (var "_Coerce")

340+ TLit Nat -> Just (var "_Nat")

280 _ -> Nothing

341 _ -> Nothing

281

342

282strict :: Type -> Type

343strict :: Type -> Type

gen/src/Gen/Types.hs+14−12

@@ -38,7 +38,7 @@ import Data.Char

38import Data.Function (on)

39import qualified Data.HashMap.Strict as Map

40import qualified Data.HashSet as Set

41−import Data.List (groupBy, sort)

41+import Data.List (groupBy, sort, sortOn)

42import Data.List.NonEmpty (NonEmpty (..))

43import qualified Data.List.NonEmpty as NE

44import Data.Maybe

@@ -374,20 +374,22 @@ instance ToJSON Data where

374 ]

375

376data Action = Action

377− { _actName :: Name

377+ { _actName :: Name

378+ , _actPrettyName :: Text

378− , _actNS :: NS

379+ , _actNS :: NS

379− , _actHelp :: Maybe Help

380+ , _actHelp :: Maybe Help

380− , _actAlias :: Rendered

381+ , _actAlias :: Rendered

381− , _actData :: Data

382+ , _actData :: Data

382 }

383 }

383

384

384instance ToJSON Action where

385instance ToJSON Action where

385 toJSON Action {..} = object

386 toJSON Action {..} = object

386− [ "name" .= Syn _actName

387+ [ "name" .= Syn _actName

388+ , "prettyName" .= _actPrettyName

387− , "ns" .= _actNS

389+ , "ns" .= _actNS

388− , "help" .= _actHelp

390+ , "help" .= _actHelp

389− , "alias" .= _actAlias

391+ , "alias" .= _actAlias

390− , "type" .= _actData

392+ , "type" .= _actData

391 ]

393 ]

392

394

393data API = API

395data API = API

@@ -400,7 +402,7 @@ instance ToJSON API where

400 toJSON API {..} = object

402 toJSON API {..} = object

401 [ "name" .= Syn _apiName

403 [ "name" .= Syn _apiName

402 , "decl" .= _apiDecl

404 , "decl" .= _apiDecl

403− , "actions" .= Map.elems _apiActions

405+ , "actions" .= sortOn _actName (Map.elems _apiActions)

404 ]

406 ]

405

407

406data Method a = Method

408data Method a = Method

gen/src/Gen/Types/Id.hs+6−5

@@ -42,13 +42,11 @@ import Language.Haskell.Exts.Build

42import Language.Haskell.Exts.Pretty (prettyPrint)

43import Language.Haskell.Exts.Syntax (Name)

45−nname :: Local -> Name

46−nname = name . Text.unpack . (<> "API") . upperHead . local

47−

48vname :: Local -> Local -> (Name, Id)

45vname :: Local -> Local -> (Name, Id)

49−vname p l = (dname n, n)

46+vname p l = (dname (g (n <> "'")), g n)

50 where

47 where

51− n = Free (Global (f p <> f l))

48+ g = Free . Global

49+ n = f p <> f l

52 f = upperHead . local

50 f = upperHead . local

54dname, cname :: Id -> Name

52dname, cname :: Id -> Name

@@ -66,6 +64,9 @@ fname = pre (Text.cons '_' . renameField)

66lname = pre renameField

64lname = pre renameField

67pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)

65pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)

67+apretty :: Local -> Local -> Text

68+apretty p l = upperHead (local l) <> " " <> upperHead (local p)

69+

69pre :: (Text -> Text) -> Pre -> Local -> Name

70pre :: (Text -> Text) -> Pre -> Local -> Name

70pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local

71pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local

gen/template/action.ede+16−1

@@ -6,13 +6,28 @@

7{% include "_include/license.ede" %}

8--

9+{{ action.type.help }}

10+--

11+-- /See:/ <{{ documentationLink }} {{ title }} Reference> for {{ action.prettyName }}.

9module {{ action.ns }}

12module {{ action.ns }}

10 (

13 (

11− -- * Resource

14+ -- * REST Resource

12 {{ action.name }}

15 {{ action.name }}

17+ -- * Creating a Request

18+ , {{ action.type.ctor.name }}

19+ , {{ action.type.name }}

20+

21+ {% for lens in action.type.lenses %}

22+ {% if lens.first %}

23+ -- * Request Lenses

24+ {% endif %}

25+ , {{ lens.value.name }}

26+ {% endfor %}

14 ) where

27 ) where

29+-- | A resource alias for {{ action.prettyName }} which the

30+-- '{{ action.type.name }}' request conforms to.

16{{ action.alias }}

31{{ action.alias }}

18{% include "_include/prod.ede" with type = action.type %}

33{% include "_include/prod.ede" with type = action.type %}

gen/template/toc.ede+10−4

@@ -11,11 +11,14 @@

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

12module {{ moduleName }}

13 (

14− -- * Resources

14+ -- * REST Resources

15 {{ api.name }}

16+ , {{ api.name | lowerHead }}

16− {% for action in api.actions %}

17+ {% for action in api.actions %}

18+

19+ -- ** {{ action.value.prettyName }}

17− , {{ action.value.name }}

20+ , module {{ action.value.ns }}

18− {% endfor %}

21+ {% endfor %}

20 -- * Types

23 -- * Types

21 {% for schema in schemas %}

24 {% for schema in schemas %}

@@ -48,3 +51,6 @@ TODO

48-}

51-}

50{{ api.decl }}

53{{ api.decl }}

54+

55+{{ api.name | lowerHead }} :: Proxy {{ api.name }}

56+{{ api.name | lowerHead }} = Proxy