git.iko.soy/gogol
on develop help sign in
Adding namespaced resource actions
3908f1bBrendan Hay
gen/src/Gen/AST.hs+58−46
compare with develop
unifiedsplit
@@ -32,6 +32,7 @@ import Data.Semigroup ((<>))
32import qualified Data.Text as Text
32import qualified Data.Text as Text
33import qualified Data.Text.Lazy as LText
33import qualified Data.Text.Lazy as LText
34import qualified Data.Text.Lazy.Builder as Build
34import qualified Data.Text.Lazy.Builder as Build
35+import Data.Traversable (for)
35import Gen.Formatting
36import Gen.Formatting
36import Gen.Solve
37import Gen.Solve
37import Gen.Syntax
38import Gen.Syntax
@@ -67,69 +68,64 @@ render svc = do
67 branch p v = Branch (bname p v) v
68 branch p v = Branch (bname p v) v
68
69
69 Obj i rs -> do
70 Obj i rs -> do
70− p <- prefix k
71+ p <- prefix k
72+ ds <- derive k
71− Just <$> (Map.traverseWithKey (const . solve . mkProp k) rs >>= prod p)
73+ dd <- Map.traverseWithKey (const . solve . mkProp k) rs
72− where
74+ Just <$> prod k p i ds dd
75+
76+ prod :: Id -> Pre -> Info -> [Derive] -> Map Local Solved -> AST Data
73− prod p ts = Prod (dname k) (i ^. description)
77+ prod k p i ds ts = Prod (dname k) (i ^. description)
74− <$> (objDecl k p ts >>= pp Indent)
78+ <$> pp Indent (objDecl k p ds ts)
75− <*> ctor p ts
79+ <*> ctor
76− <*> traverse (lens p) (Map.toList ts)
80+ <*> traverse lens (Map.toList ts)
77− <*> traverse (pp Print) (jsonDecls k p ts)
81+ <*> traverse (pp Print) (jsonDecls k p ts)
78−
82+ where
79− ctor p ts = Fun' (cname k) (Just help)
83+ ctor = Fun' (cname k) (Just help)
80− <$> (pp None (ctorSig k ts) <&> comments ts)
84+ <$> (pp None (ctorSig k ts) <&> comments ts)
81− <*> pp Indent (ctorDecl k p ts)
85+ <*> pp Indent (ctorDecl k p ts)
82
86
83− lens p (l, v) = Fun' (lname p l) (v ^. description)
87+ lens (l, v) = Fun' (lname p l) (v ^. description)
84− <$> pp None (lensSig k p l v)
88+ <$> pp None (lensSig k p l v)
85− <*> pp Print (lensDecl p l v)
89+ <*> pp Print (lensDecl p l v)
86
90
87− help = rawHelpText $
91+ help = rawHelpText $
88− sformat ("Creates a value of '" % fid %
92+ sformat ("Creates a value of '" % fid %
89− "' with the minimum fields required to make a request.\n")
93+ "' with the minimum fields required to make a request.\n")
90− k
94+ k
91
95
92 api :: Resource -> AST API
96 api :: Resource -> AST API
97+ api x = do
98+ as <- Map.fromList <$> top x
93− api x = API n <$> pp Print (apiAlias n (nouns x)) <*> top x
99+ API n <$> pp Print (apiAlias n (Map.keys as))
100+ <*> pure as
94 where
101 where
95 n = name (Text.unpack (svcAbbrev svc))
102 n = name (Text.unpack (svcAbbrev svc))
96
103
97− nouns = map nname . \case
98− Top rs -> Map.keys rs
99− Sub ms -> Map.keys ms
100−
101− top :: Resource -> AST [Action]
102 top = \case
104 top = \case
103 Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
105 Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
104 Sub ms -> traverse (uncurry (verb "")) (Map.toList ms)
106 Sub ms -> traverse (uncurry (verb "")) (Map.toList ms)
105
107
106− sub :: Local -> Resource -> AST [Action]
107 sub l = \case
108 sub l = \case
108− t@(Top rs) -> do
109− let k = nname l
110− t <- Action k Nothing
111− <$> pp Print (apiAlias k (nouns t))
112− as <- traverse (uncurry sub) (Map.toList rs) <&> concat
109+ Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
113− return (t : as)
114−
115− Sub ms -> do
116− let k = nname l
117− t <- Action k Nothing
118− <$> pp Print (apiAlias k (map (vname l) $ Map.keys ms))
119− as <- traverse (uncurry (verb l)) (Map.toList ms)
110+ Sub ms -> traverse (uncurry (verb l)) (Map.toList ms)
120− return (t : as)
111+
121−
112+ verb p l m = do
122− verb :: Local -> Local -> Method -> AST Action
113+ let (k, i) = vname p l
114+ s <- solve i
115+ Just d <- typ i (_schema s)
116+ fmap (k,) $
123− verb p l m = Action (vname p l) (_mDescription m)
117+ Action k (actionNS svc p l) (_mDescription m)
124− <$> pp Print (verbDecl svc p l m)
118+ <$> pp Print (verbAlias svc k m)
119+ <*> pure d
125
120
126flatten :: Service (Fix Schema) Resource -> Service (Schema Id) Resource
121flatten :: Service (Fix Schema) Resource -> Service (Schema Id) Resource
127flatten svc = svc { _svcSchemas = execState run mempty }
122flatten svc = svc { _svcSchemas = execState run mempty }
128 where
123 where
129− run = mapM_ (uncurry top) (Map.toList (_svcSchemas svc))
124+ run = mapM_ (uncurry sch) (Map.toList (_svcSchemas svc))
125+ >> api (_svcApi svc)
130
126
131− top :: Id -> Fix Schema -> State (Map Id (Schema Id)) Id
127+ sch :: Id -> Fix Schema -> State (Map Id (Schema Id)) Id
132− top n (Fix f) = go f >>= ins n
128+ sch n (Fix f) = go f >>= ins n
133 where
129 where
134 go = \case
130 go = \case
135 Obj i ps -> Obj i <$> Map.traverseWithKey (prop n) ps
131 Obj i ps -> Obj i <$> Map.traverseWithKey (prop n) ps
@@ -154,6 +150,22 @@ flatten svc = svc { _svcSchemas = execState run mempty }
154
150
155 this = mkProp n l
151 this = mkProp n l
156
152
153+ api :: Resource -> State (Map Id (Schema Id)) ()
154+ api = \case
155+ Top rs -> mapM_ (uncurry sub) (Map.toList rs)
156+ Sub ms -> mapM_ (uncurry (verb "")) (Map.toList ms)
157+ where
158+ sub l = \case
159+ Top rs -> mapM_ (uncurry sub) (Map.toList rs)
160+ Sub ms -> mapM_ (uncurry (verb l)) (Map.toList ms)
161+
162+ -- FIXME: Global parameters
163+ verb p l m = do
164+ let (_, i) = vname p l
165+ rs <- Map.traverseWithKey (\k v -> prop i k (paramSchema v)) (_mParameters m)
166+ void . ins i $
167+ Obj (Info (_mDescription m) Nothing False Nothing) rs
168+
157 ins :: Id -> Schema Id -> State (Map Id (Schema Id)) Id
169 ins :: Id -> Schema Id -> State (Map Id (Schema Id)) Id
158 ins n x = do
170 ins n x = do
159 s <- gets (Map.lookup n)
171 s <- gets (Map.lookup n)
gen/src/Gen/Solve.hs+14−14
@@ -137,25 +137,25 @@ derive :: Id -> AST [Derive]
137derive k = loc "derive" k $ memo derived k go
137derive k = loc "derive" k $ memo derived k go
138 where
138 where
139 go = \case
139 go = \case
140− Obj _ rs -> foldM props base (Map.elems rs)
140+ Obj _ rs -> foldM props dbase (Map.elems rs)
141− Arr _ r -> mappend monoid . intersect base <$> derive r
141+ Arr _ r -> mappend dmonoid . intersect dbase <$> derive r
142− Enum {} -> pure (base <> enum)
142+ Enum {} -> pure denum
143− Ref _ r -> pure base
143+ Ref _ r -> pure dbase
144− Any _ -> pure base
144+ Any _ -> pure dbase
145 Lit _ l -> pure $
145 Lit _ l -> pure $
146 case l of
146 case l of
147− Text -> base <> [DOrd, DIsString]
147+ Text -> dbase <> [DOrd, DIsString]
148− Bool -> base <> enum
148+ Bool -> denum
149− Time -> base
149+ Time -> dbase
150− Date -> base
150+ Date -> dbase
151− Nat -> base
151+ Nat -> dbase
152− _ -> base <> [DNum, DIntegral, DReal] <> enum
152+ _ -> [DNum, DIntegral, DReal] <> denum
153
153
154 props ds x = intersect ds <$> derive x
154 props ds x = intersect ds <$> derive x
155
155
156− monoid = [DMonoid]
156+dmonoid = [DMonoid]
157− enum = [DOrd, DEnum]
157+denum = [DOrd, DEnum] <> dbase
158− base = [DEq, DRead, DShow, DData, DTypeable, DGeneric]
158+dbase = [DEq, DRead, DShow, DData, DTypeable, DGeneric]
159
159
160prefix :: Id -> AST Pre
160prefix :: Id -> AST Pre
161prefix n = loc "prefix" n $ memo prefixed n typ
161prefix n = loc "prefix" n $ memo prefixed n typ
gen/src/Gen/Syntax.hs+6−7
@@ -40,8 +40,8 @@ apiAlias n ls = TypeDecl noLoc n [] alias
40 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
40 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
41
41
42-- type Method = :> ...
42-- type Method = :> ...
43−verbDecl :: Service s r -> Local -> Local -> Method -> Decl
43+verbAlias :: Service s r -> Name -> Method -> Decl
44−verbDecl s p l m = TypeDecl noLoc (vname p l) [] alias
44+verbAlias s n m = TypeDecl noLoc n [] alias
45 where
45 where
46 alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) verb (path ++ qry)
46 alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) verb (path ++ qry)
47
47
@@ -154,14 +154,16 @@ seqE :: Exp -> [Exp] -> Exp
154seqE l [] = app (var "pure") l
154seqE l [] = app (var "pure") l
155seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
155seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
156
156
157−objDecl :: Id -> Pre -> Map Local Solved -> AST Decl
157+objDecl :: Id -> Pre -> [Derive] -> Map Local Solved -> Decl
158−objDecl n p rs = DataDecl noLoc arity [] d [] [conDecl d p rs] <$> derivings n
158+objDecl n p ds rs = DataDecl noLoc arity [] d [] [conDecl d p rs] (der ds)
159 where
159 where
160 d = dname n
160 d = dname n
161
161
162 arity | Map.size rs == 1 = NewType
162 arity | Map.size rs == 1 = NewType
163 | otherwise = DataType
163 | otherwise = DataType
164
164
165+ der = map ((,[]) . unqual . drop 1 . show)
166+
165conDecl :: Name -> Pre -> Map Local Solved -> QualConDecl
167conDecl :: Name -> Pre -> Map Local Solved -> QualConDecl
166conDecl n p rs = QualConDecl noLoc [] [] body
168conDecl n p rs = QualConDecl noLoc [] [] body
167 where
169 where
@@ -216,9 +218,6 @@ lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
216 (paren (lamE noLoc [pvar "s", pvar "a"]
218 (paren (lamE noLoc [pvar "s", pvar "a"]
217 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
219 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
218
220
219−derivings :: Id -> AST [Deriving]
220−derivings k = map ((,[]) . unqual . drop 1 . show) <$> derive k
221−
222parameters :: [Solved] -> [Type]
221parameters :: [Solved] -> [Type]
223parameters = map (external . _type) . filter (view required)
222parameters = map (external . _type) . filter (view required)
224
223
gen/src/Gen/Tree.hs+4−1
@@ -27,6 +27,7 @@ import Control.Monad.Except
27import Data.Aeson hiding (json)
27import Data.Aeson hiding (json)
28import Data.Bifunctor
28import Data.Bifunctor
29import Data.Foldable (foldr')
29import Data.Foldable (foldr')
30+import qualified Data.HashMap.Strict as Map
30import qualified Data.List.NonEmpty as NE
31import qualified Data.List.NonEmpty as NE
31import Data.Monoid
32import Data.Monoid
32import Data.Text (Text)
33import Data.Text (Text)
@@ -84,8 +85,10 @@ populate d Templates{..} l = (encodeString d :/) . dir lib <$> layout
84 , mod' (typesNS s) (typeImports s) typesTemplate (pure svc)
85 , mod' (typesNS s) (typeImports s) typesTemplate (pure svc)
85 , mod' (prodNS s) (prodImports s) prodTemplate (pure svc)
86 , mod' (prodNS s) (prodImports s) prodTemplate (pure svc)
86 , mod' (sumNS s) (sumImports s) sumTemplate (pure svc)
87 , mod' (sumNS s) (sumImports s) sumTemplate (pure svc)
87− ]
88+ ] ++ map action (svcActions s)
88 where
89 where
90+ action n = mod' n (actionImports s) actionTemplate (pure svc)
91+
89 svc = toJSON s
92 svc = toJSON s
90
93
91 lib = fromText (_libName l)
94 lib = fromText (_libName l)
gen/src/Gen/Types.hs+42−15
@@ -36,8 +36,9 @@ import Data.Aeson hiding (Bool, String)
36import Data.Aeson.TH
36import Data.Aeson.TH
37import Data.Char
37import Data.Char
38import Data.Function (on)
38import Data.Function (on)
39+import qualified Data.HashMap.Strict as Map
39import qualified Data.HashSet as Set
40import qualified Data.HashSet as Set
40−import Data.List (groupBy)
41+import Data.List (groupBy, sort)
41import Data.List.NonEmpty (NonEmpty (..))
42import Data.List.NonEmpty (NonEmpty (..))
42import qualified Data.List.NonEmpty as NE
43import qualified Data.List.NonEmpty as NE
43import Data.Maybe
44import Data.Maybe
@@ -82,6 +83,7 @@ data Templates = Templates
82 , typesTemplate :: Template
83 , typesTemplate :: Template
83 , prodTemplate :: Template
84 , prodTemplate :: Template
84 , sumTemplate :: Template
85 , sumTemplate :: Template
86+ , actionTemplate :: Template
85 }
87 }
86
88
87newtype Version (v :: Symbol) = Version Text
89newtype Version (v :: Symbol) = Version Text
@@ -271,6 +273,13 @@ data Param = Param
271 , _prmLiteral :: !Lit
273 , _prmLiteral :: !Lit
272 }
274 }
273
275
276+paramSchema :: Param -> Fix Schema
277+paramSchema p
278+ | _prmRepeated p = Fix $ Arr (_prmInfo p) lit
279+ | otherwise = lit
280+ where
281+ lit = Fix $ Lit (_prmInfo p) (_prmLiteral p)
282+
274instance FromJSON Param where
283instance FromJSON Param where
275 parseJSON = withObject "parameter" $ \o -> Param
284 parseJSON = withObject "parameter" $ \o -> Param
276 <$> o .: "location"
285 <$> o .: "location"
@@ -327,22 +336,33 @@ instance ToJSON Data where
327 , "instances" .= is
336 , "instances" .= is
328 ]
337 ]
329
338
330−data Action = Action Name (Maybe Help) Rendered
339+data Action = Action
340+ { _actName :: Name
341+ , _actNS :: NS
342+ , _actHelp :: Maybe Help
343+ , _actAlias :: Rendered
344+ , _actData :: Data
345+ }
331
346
332instance ToJSON Action where
347instance ToJSON Action where
333− toJSON (Action n h d) = object
348+ toJSON (Action n _ h a d) = object
334− [ "name" .= Syn n
349+ [ "name" .= Syn n
335− , "help" .= h
350+ , "help" .= h
336− , "decl" .= d
351+ , "alias" .= a
352+ , "data" .= d
337 ]
353 ]
338
354
339−data API = API Name Rendered [Action]
355+data API = API
356+ { _apiName :: Name
357+ , _apiDecl :: Rendered
358+ , _apiActions :: Map Name Action
359+ }
340
360
341instance ToJSON API where
361instance ToJSON API where
342 toJSON (API n d as) = object
362 toJSON (API n d as) = object
343 [ "name" .= Syn n
363 [ "name" .= Syn n
344 , "decl" .= d
364 , "decl" .= d
345− , "actions" .= as
365+ , "actions" .= Map.elems as
346 ]
366 ]
347
367
348data Method = Method
368data Method = Method
@@ -440,10 +460,14 @@ instance ToJSON (Service Data API) where
440svcAbbrev :: Service s r -> Text
460svcAbbrev :: Service s r -> Text
441svcAbbrev = upperHead . renameAbbrev . _svcCanonicalName
461svcAbbrev = upperHead . renameAbbrev . _svcCanonicalName
442
462
463+svcActions :: Service s API -> [NS]
464+svcActions = map _actNS . Map.elems . _apiActions . _svcApi
465+
443−typeImports, prodImports, sumImports :: Service s r -> [NS]
466+typeImports, prodImports, sumImports, actionImports :: Service s r -> [NS]
444−typeImports s = ["Network.Google.Prelude", prodNS s, sumNS s]
467+typeImports s = sort ["Network.Google.Prelude", prodNS s, sumNS s]
445−prodImports s = ["Network.Google.Prelude", sumNS s]
468+prodImports s = sort ["Network.Google.Prelude", sumNS s]
446−sumImports _ = ["Network.Google.Prelude"]
469+sumImports _ = sort ["Network.Google.Prelude"]
470+actionImports = typeImports
447
471
448tocNS, typesNS, prodNS, sumNS :: Service s r -> NS
472tocNS, typesNS, prodNS, sumNS :: Service s r -> NS
449tocNS s = NS $ "Network" : "Google" : Text.split (== '.') (_svcCanonicalName s)
473tocNS s = NS $ "Network" : "Google" : Text.split (== '.') (_svcCanonicalName s)
@@ -451,11 +475,14 @@ typesNS = (<> "Types") . tocNS
451prodNS = (<> "Product") . typesNS
475prodNS = (<> "Product") . typesNS
452sumNS = (<> "Sum") . typesNS
476sumNS = (<> "Sum") . typesNS
453
477
454−exposedModules :: Service s r -> [NS]
478+actionNS :: Service s r -> Local -> Local -> NS
455−exposedModules s = [tocNS s, typesNS s]
479+actionNS s x y = tocNS s <> NS [upperHead (local x), upperHead (local y)]
480+
481+exposedModules :: Service s API -> [NS]
482+exposedModules s = sort (tocNS s : typesNS s : svcActions s)
456
483
457otherModules :: Service s r -> [NS]
484otherModules :: Service s r -> [NS]
458−otherModules s = [prodNS s, sumNS s]
485+otherModules s = sort [prodNS s, sumNS s]
459
486
460data Library = Library
487data Library = Library
461 { _libName :: Text
488 { _libName :: Text
gen/src/Gen/Types/Id.hs+5−4
@@ -45,10 +45,11 @@ import Language.Haskell.Exts.Syntax (Name)
45nname :: Local -> Name
45nname :: Local -> Name
46nname = name . Text.unpack . (<> "API") . upperHead . local
46nname = name . Text.unpack . (<> "API") . upperHead . local
47
47
48−vname :: Local -> Local -> Name
48+vname :: Local -> Local -> (Name, Id)
49−vname p l = name (f p <> f l)
49+vname p l = (dname n, n)
50 where
50 where
51+ n = Free (Global (f p <> f l))
51− f = Text.unpack . upperHead . local
52+ f = upperHead . local
52
53
53dname, cname :: Id -> Name
54dname, cname :: Id -> Name
54dname = name . Text.unpack . upperHead . idToText
55dname = name . Text.unpack . upperHead . idToText
@@ -63,7 +64,7 @@ bname (Pre p) = name
63fname, lname, pname :: Pre -> Local -> Name
64fname, lname, pname :: Pre -> Local -> Name
64fname = pre (Text.cons '_' . renameField)
65fname = pre (Text.cons '_' . renameField)
65lname = pre renameField
66lname = pre renameField
66−pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead)
67+pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)
67
68
68pre :: (Text -> Text) -> Pre -> Local -> Name
69pre :: (Text -> Text) -> Pre -> Local -> Name
69pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local
70pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local
gen/src/Main.hs+1
@@ -138,6 +138,7 @@ main = do
138 <*> load "types.ede"
138 <*> load "types.ede"
139 <*> load "prod.ede"
139 <*> load "prod.ede"
140 <*> load "sum.ede"
140 <*> load "sum.ede"
141+ <*> load "action.ede"
141 <* done
142 <* done
142
143
143 title "Selecting new service models..."
144 title "Selecting new service models..."
gen/template/action.edenew file+7
@@ -0,0 +1,7 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeOperators #-}
3+
4+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
5+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
6+
7+{% include "_include/license.ede" %}
gen/template/toc.ede−7
@@ -48,10 +48,3 @@ TODO
48-}
48-}
49
49
50{{ api.decl }}
50{{ api.decl }}
51−{% for action in api.actions %}
52−
53−{% if action.value.help %}
54−{{ action.value.help }}
55−{% endif %}
56−{{ action.value.decl }}
57−{% endfor %}