git.iko.soy/gogol
on develop help sign in
Rendering GoogleRequest instances
commitfff74437cd9724b873b26bb6d4efe32416e9343e authorBrendan Hay <brendan.g.hay@gmail.com> dateMon 28 Sep 2015, 11:04 (11 years ago) parent3ad8335
6 files changed+139−47
compare with develop
unifiedsplit
gen/src/Gen/AST.hs+13−6 gen/src/Gen/Syntax.hs+80−19 gen/src/Gen/Types.hs+14−12 gen/src/Gen/Types/Id.hs+6−5 gen/template/action.ede+16−1 gen/template/toc.ede+10−4
gen/src/Gen/AST.hs+13−6
@@ -110,13 +110,20 @@ render svc = do
110110 s <- solve i
111111 Just d <- typ s
112112 fmap (k,) $
113− Action k (actionNS svc p l) (_mDescription m)
113+ Action k (apretty p l) (actionNS svc p l) (_mDescription m)
114114 <$> pp Print (verbAlias svc k m)
115− <*> pure (reset d)
116−
117− reset = \case
118− Prod n' h r c ls _ -> Prod n' h r c ls []
119− d -> d
115+ <*> reset m s d
116+
117+ reset m s = \case
118+ d@Sum {} -> pure d
119+ Prod n' h r c ls _ ->
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
120127
121128solveAll :: Flattened -> AST Typed
122129solveAll svc = do
gen/src/Gen/Syntax.hs+80−19
@@ -45,6 +45,9 @@ verbAlias s n m = TypeDecl noLoc n [] alias
4545 where
4646 alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) verb (path ++ qry)
4747
48+ -- FIXME: rather than using 'terminal' to get the terminal type,
49+ -- write a custom 'Link' for servant to specify required params.
50+
4851 path :: [Type]
4952 path = map match
5053 . filter (not . Text.null)
@@ -59,7 +62,7 @@ verbAlias s n m = TypeDecl noLoc n [] alias
5962 , _prmLocation k == Path
6063 = TyApp (TyApp (tycon "Capture")
6164 (sing (Text.init t)))
62− (external (_type (_prmSchema k)))
65+ (terminalType (_type (_prmSchema k)))
6366 | otherwise = sing x
6467
6568 -- FIXME: order by _mParameterOrder
@@ -67,11 +70,12 @@ verbAlias s n m = TypeDecl noLoc n [] alias
6770 qry = mapMaybe f (Map.toList params)
6871 where
6972 f (k, x) =
70− -- FIXME: types, many/repeated
71− let t = external (_type (_prmSchema x))
73+ let t = terminalType (_type (_prmSchema x))
7274 n = sing (local k)
7375 in case _prmLocation x of
7476 Query -> Just $ TyApp (TyApp (tycon "QueryParam") n) t
77+ Query | _prmRepeated x
78+ -> Just $ TyApp (TyApp (tycon "QueryParams") n) t
7579 Path -> Nothing
7680
7781 params = _mParameters m
@@ -83,6 +87,35 @@ verbAlias s n m = TypeDecl noLoc n [] alias
8387 typ = tycon "'[JSON]"
8488 res = maybe (tycon "()") (tycon . Free) (_mResponse m)
8589
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+
86119jsonDecls :: Id -> Pre -> Map Local Solved -> [Decl]
87120jsonDecls n p (Map.toList -> rs) = [from, to]
88121 where
@@ -170,8 +203,8 @@ conDecl n p rs = QualConDecl noLoc [] [] body
170203 where
171204 body = case Map.toList rs of
172205 [] -> ConDecl n []
173− [x] -> RecDecl n [field internal x]
174− xs -> RecDecl n (map (field (strict . internal)) xs)
206+ [x] -> RecDecl n [field internalType x]
207+ xs -> RecDecl n (map (field (strict . internalType)) xs)
175208
176209 field f (l, v) = ([fname p l], f (_type v))
177210
@@ -206,7 +239,7 @@ fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
206239lensSig :: Id -> Pre -> Local -> Solved -> Decl
207240lensSig n p l s = TypeSig noLoc [lname p l] $
208241 TyApp (TyApp (tycon "Lens'") (tycon n))
209− (external (_type s))
242+ (externalType (_type s))
210243
211244lensDecl :: Pre -> Local -> Solved -> Decl
212245lensDecl 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
220253 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
221254
222255parameters :: [Solved] -> [Type]
223−parameters = map (external . _type) . filter (view required)
256+parameters = map (externalType . _type) . filter (view required)
224257
225258def :: Solved -> Maybe Exp
226259def s
@@ -236,20 +269,32 @@ def s
236269
237270 lit = var . name . Text.unpack
238271
239−external, internal :: TType -> Type
240−external = internal . \case
241− TMaybe t@TList {} -> t
242− t -> t
243−
244−internal = \case
272+terminalType :: TType -> Type
273+terminalType = internalType . go
274+ where
275+ go (TMaybe x) = x
276+ go (TList x) = x
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
245290 TType r -> tycon r
246− TMaybe t -> TyApp (tycon "Maybe") (internal t)
247− TEither a b -> TyApp (TyApp (tycon "Either") (internal a)) (internal b)
248− TList t -> TyList (internal t)
249− TLit l -> literal l
291+ TMaybe t -> TyApp (tycon "Maybe") (internalType t)
292+ TEither a b -> TyApp (TyApp (tycon "Either") (internalType a)) (internalType b)
293+ TList t -> TyList (internalType t)
294+ TLit l -> internalLit l
250295
251−literal :: Lit -> Type
252−literal = \case
296+externalLit :: Lit -> Type
297+externalLit = \case
253298 Text -> tycon "Text"
254299 Bool -> tycon "Bool"
255300 Time -> tycon "UTCTime"
@@ -263,6 +308,21 @@ literal = \case
263308 Int32 -> tycon "Int32"
264309 Int64 -> tycon "Int64"
265310
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+
266326mapping :: TType -> Exp -> Exp
267327mapping t e = infixE e "." (go t)
268328 where
@@ -277,6 +337,7 @@ mapping t e = infixE e "." (go t)
277337iso :: TType -> Maybe Exp
278338iso = \case
279339 TList {} -> Just (var "_Coerce")
340+ TLit Nat -> Just (var "_Nat")
280341 _ -> Nothing
281342
282343strict :: Type -> Type
gen/src/Gen/Types.hs+14−12
@@ -38,7 +38,7 @@ import Data.Char
3838import Data.Function (on)
3939import qualified Data.HashMap.Strict as Map
4040import qualified Data.HashSet as Set
41−import Data.List (groupBy, sort)
41+import Data.List (groupBy, sort, sortOn)
4242import Data.List.NonEmpty (NonEmpty (..))
4343import qualified Data.List.NonEmpty as NE
4444import Data.Maybe
@@ -374,20 +374,22 @@ instance ToJSON Data where
374374 ]
375375
376376data Action = Action
377− { _actName :: Name
378− , _actNS :: NS
379− , _actHelp :: Maybe Help
380− , _actAlias :: Rendered
381− , _actData :: Data
377+ { _actName :: Name
378+ , _actPrettyName :: Text
379+ , _actNS :: NS
380+ , _actHelp :: Maybe Help
381+ , _actAlias :: Rendered
382+ , _actData :: Data
382383 }
383384
384385instance ToJSON Action where
385386 toJSON Action {..} = object
386− [ "name" .= Syn _actName
387− , "ns" .= _actNS
388− , "help" .= _actHelp
389− , "alias" .= _actAlias
390− , "type" .= _actData
387+ [ "name" .= Syn _actName
388+ , "prettyName" .= _actPrettyName
389+ , "ns" .= _actNS
390+ , "help" .= _actHelp
391+ , "alias" .= _actAlias
392+ , "type" .= _actData
391393 ]
392394
393395data API = API
@@ -400,7 +402,7 @@ instance ToJSON API where
400402 toJSON API {..} = object
401403 [ "name" .= Syn _apiName
402404 , "decl" .= _apiDecl
403− , "actions" .= Map.elems _apiActions
405+ , "actions" .= sortOn _actName (Map.elems _apiActions)
404406 ]
405407
406408data Method a = Method
gen/src/Gen/Types/Id.hs+6−5
@@ -42,13 +42,11 @@ import Language.Haskell.Exts.Build
4242import Language.Haskell.Exts.Pretty (prettyPrint)
4343import Language.Haskell.Exts.Syntax (Name)
4444
45−nname :: Local -> Name
46−nname = name . Text.unpack . (<> "API") . upperHead . local
47−
4845vname :: Local -> Local -> (Name, Id)
49−vname p l = (dname n, n)
46+vname p l = (dname (g (n <> "'")), g n)
5047 where
51− n = Free (Global (f p <> f l))
48+ g = Free . Global
49+ n = f p <> f l
5250 f = upperHead . local
5351
5452dname, cname :: Id -> Name
@@ -66,6 +64,9 @@ fname = pre (Text.cons '_' . renameField)
6664lname = pre renameField
6765pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)
6866
67+apretty :: Local -> Local -> Text
68+apretty p l = upperHead (local l) <> " " <> upperHead (local p)
69+
6970pre :: (Text -> Text) -> Pre -> Local -> Name
7071pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local
7172
gen/template/action.ede+16−1
@@ -6,13 +6,28 @@
66
77{% include "_include/license.ede" %}
88--
9+{{ action.type.help }}
10+--
11+-- /See:/ <{{ documentationLink }} {{ title }} Reference> for {{ action.prettyName }}.
912module {{ action.ns }}
1013 (
11− -- * Resource
14+ -- * REST Resource
1215 {{ action.name }}
1316
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 %}
1427 ) where
1528
29+-- | A resource alias for {{ action.prettyName }} which the
30+-- '{{ action.type.name }}' request conforms to.
1631{{ action.alias }}
1732
1833{% include "_include/prod.ede" with type = action.type %}
gen/template/toc.ede+10−4
@@ -11,11 +11,14 @@
1111-- /See:/ <{{ documentationLink }} {{ title }} Reference>
1212module {{ moduleName }}
1313 (
14− -- * Resources
14+ -- * REST Resources
1515 {{ api.name }}
16− {% for action in api.actions %}
17− , {{ action.value.name }}
18− {% endfor %}
16+ , {{ api.name | lowerHead }}
17+ {% for action in api.actions %}
18+
19+ -- ** {{ action.value.prettyName }}
20+ , module {{ action.value.ns }}
21+ {% endfor %}
1922
2023 -- * Types
2124 {% for schema in schemas %}
@@ -48,3 +51,6 @@ TODO
4851-}
4952
5053{{ api.decl }}
54+
55+{{ api.name | lowerHead }} :: Proxy {{ api.name }}
56+{{ api.name | lowerHead }} = Proxy