git.iko.soy/gogol
on develop help sign in
Rendering resource methods as separate type aliases to reduce noise/haddock explosion
commitf9920b0c9d8b65770348bc00931784125712607d authorBrendan Hay <brendan.g.hay@gmail.com> dateFri 25 Sep 2015, 07:58 (11 years ago) parentb38c700
8 files changed+176−192
compare with develop
unifiedsplit
gen/gozen-gen.cabal+1 gen/src/Gen/AST.hs+43−78 gen/src/Gen/Solve.hs+42−11 gen/src/Gen/Syntax.hs+33−33 gen/src/Gen/Types.hs+27−58 gen/src/Gen/Types/Id.hs+9−3 gen/src/Main.hs+2−1 gen/template/toc.ede+19−8
gen/gozen-gen.cabal+1
@@ -43,6 +43,7 @@ executable gozen-gen
4343 , bytestring
4444 , directory-tree
4545 , ede
46+ , bifunctors
4647 , errors
4748 , formatting
4849 , hashable
gen/src/Gen/AST.hs+43−78
@@ -1,4 +1,5 @@
11{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TupleSections #-}
23{-# LANGUAGE DeriveGeneric #-}
34{-# LANGUAGE FlexibleContexts #-}
45{-# LANGUAGE FlexibleInstances #-}
@@ -24,7 +25,7 @@ import Control.Applicative
2425import Control.Error
2526import Control.Lens hiding (lens)
2627import Control.Monad.Except
27−import Control.Monad.State
28+import Control.Monad.State.Strict
2829import Data.Char
2930import Data.Function (on)
3031import qualified Data.HashMap.Strict as Map
@@ -42,73 +43,16 @@ import HIndent
4243import Language.Haskell.Exts.Pretty
4344import Prelude hiding (sum)
4445
45−runAST :: Versions
46− -> [Service (Fix Schema) (Fix Schema) (Resource (Fix Schema))]
47− -> Either Error [Library]
48−runAST v ss = merge v <$> evalState (runExceptT go) initial
46+--runAST :: Service (Schema Id) Resource -> Either Error a
47+runAST svc = evalState (runExceptT (render ss)) (initial (_svcSchemas ss))
4948 where
50− go = traverse (flatten >=> render) ss
51−
52−flatten :: Service (Fix Schema) (Fix Schema) (Resource (Fix Schema))
53− -> AST (Service (Schema Id) (Schema Id) (Resource (Schema Id)))
54−flatten svc = do
55− mapM_ (uncurry (prop Nothing)) (Map.toList (_svcSchemas svc))
56− ss <- gets (view schemas)
57− ps <- Map.traverseWithKey global (_svcParameters svc)
58− rs <- Map.traverseWithKey resource (_svcResources svc)
59− return $! svc { _svcSchemas = ss, _svcParameters = ps, _svcResources = rs }
60− where
61− resource :: Id -> Resource (Fix Schema) -> AST (Resource (Schema Id))
62− resource k (Resource ms) = Resource <$> traverse go ms
63− where
64− go m = do
65− ps <- Map.traverseWithKey (local k) (_mParameters m)
66− return $! m { _mParameters = ps }
67−
68− global = param (Just "param")
69− local k = param (Just k)
70−
71− param :: Maybe Id -> Id -> Param (Fix Schema) -> AST (Param (Schema Id))
72− param p k (Param l m f) = do
73− n <- prop p k f
74− s <- schema n
75− return $! Param l m s
76−
77− -- unfold a schema property.
78− prop :: Maybe Id
79− -> Id
80− -> Fix Schema
81− -> AST Id
82− prop p k (Fix f) = case f of
83− Obj i ps -> do
84− o <- Obj i <$> Map.traverseWithKey (prop (Just this)) ps
85− res o
49+ ss = flatten svc
8650
87− Arr i (Fix e) -> do
88− e' <- prop (Just this) "item" (Fix (e & required .~ True))
89− res (Arr i e')
90−
91− Enum i vs ds -> res (Enum i vs ds)
92− Lit i l -> res (Lit i l)
93− Ref _ r -> pure r
94− Any i -> res (Any i)
95− where
96− res x = do
97− s <- gets (Map.lookup this . view schemas)
98− case s of
99− Nothing -> (schemas %= Map.insert this x) >> pure this
100− -- FIXME:
101− Just e -> error $ "Already exists: " ++ show (this, e, x)
102−
103− this = maybe k (<> k) p
104−
105−render :: Service (Schema Id) (Schema Id) (Resource (Schema Id))
106− -> AST (Service Data Solved API)
51+render :: Service (Schema Id) Resource -> AST (Service Data API)
10752render svc = do
108− x <- kvTraverseMaybe typ (_svcSchemas svc)
109− y <- Map.traverseWithKey prm (_svcParameters svc)
110− z <- Map.traverseWithKey (api y) (_svcResources svc)
111− return $! svc { _svcSchemas = x, _svcParameters = y, _svcResources = z }
53+ x <- kvTraverseMaybe typ (_svcSchemas svc)
54+ y <- Map.traverseWithKey api (_svcResources svc)
55+ return $! svc { _svcSchemas = x, _svcResources = y }
11256 where
11357 typ :: Id -> Schema Id -> AST (Maybe Data)
11458 typ k = \case
@@ -140,24 +84,45 @@ render svc = do
14084 sformat ("Creates a value of '" % fid %
14185 "' with the minimum fields required to make a request.\n")
14286 k
87+ api :: Id -> Resource -> AST API
88+ api k (methods -> Map.toList -> ms) = do
89+ let go (n, v) = fmap (mname k n,) . traverse (pp None) $ apiTypes svc k v
90+ rs <- traverse go ms
91+ return $! API (aname k) (Map.fromList rs)
92+
93+flatten :: Service (Fix Schema) Resource -> Service (Schema Id) Resource
94+flatten svc = svc
95+ { _svcSchemas = execState (mapM_ (uncurry (prop Nothing)) ss) mempty
96+ }
97+ where
98+ ss = Map.toList (_svcSchemas svc)
99+
100+ -- unfold the properties.
101+ prop p k (Fix f) = case f of
102+ Obj i ps -> do
103+ o <- Obj i <$> Map.traverseWithKey (prop (Just this)) ps
104+ res o
143105
144−Make param types lit only, and fail at json parse time?
145−Then avoid any solving/id memo steps.
106+ Arr i (Fix e) -> do
107+ e' <- prop (Just this) "item" (Fix (e & required .~ True))
108+ res (Arr i e')
146109
147− prm :: Id -> Param (Schema Id) -> AST (Param Solved)
148− prm r p = do
149− let k = "param" <> r
150− traverse (const (solve k)) p
110+ Enum i vs ds -> res (Enum i vs ds)
111+ Lit i l -> res (Lit i l)
112+ Ref _ r -> pure r
113+ Any i -> res (Any i)
151114
152− api :: Map Id (Param Solved) -> Id -> Resource (Schema Id) -> AST API
153− api cmn k (methods -> Map.toList -> ms) = do
154− z <- Map.traverseWithKey (\n p -> traverse (const $ solve (k <> n)) p) (_mParameters y)
155− API (aname k) <$>
156− traverse (pp None) (apiTypes svc cmn x (y { _mParameters = z }))
157115 where
158− (x, y) = head ms
116+ res x = do
117+ s <- gets (Map.lookup this)
118+ case s of
119+ Nothing -> modify (Map.insert this x) >> pure this
120+ -- FIXME:
121+ Just e -> error $ "Already exists: " ++ show (this, e, x)
122+
123+ this = maybe k (<> k) p
159124
160−merge :: Versions -> [Service Data Solved API] -> [Library]
125+merge :: Versions -> [Service Data API] -> [Library]
161126merge v = map go . groupBy (on (==) _svcLibrary)
162127 where
163128 go [x] = mk x
gen/src/Gen/Solve.hs+42−11
@@ -21,36 +21,67 @@ module Gen.Solve where
2121
2222import Control.Applicative
2323import Control.Error
24−import Control.Lens hiding (enum)
24+import Control.Lens hiding (enum)
2525import Control.Monad.Except
26−import Control.Monad.State
27−import qualified Data.HashMap.Strict as Map
28−import Data.List (intersect)
26+import Control.Monad.State.Strict
27+import qualified Data.HashMap.Strict as Map
28+import Data.List (intersect)
2929import Data.Maybe
30−import Data.Semigroup ((<>))
30+import Data.Semigroup ((<>))
3131import Gen.Formatting
3232import Gen.Types
33−import Prelude hiding (sum)
33+import Prelude hiding (sum)
3434
3535-- Just use hashmaps to lookup refs etc, and hide all the mutation
3636-- behind a StateT interface.
3737
38+data TType
39+ = TType Id
40+ | TLit Lit
41+ | TMaybe TType
42+ | TEither TType TType
43+ | TList TType
44+
45+data Derive
46+ = DEq
47+ | DOrd
48+ | DRead
49+ | DShow
50+ | DEnum
51+ | DNum
52+ | DIntegral
53+ | DReal
54+ | DMonoid
55+ | DIsString
56+ | DData
57+ | DTypeable
58+ | DGeneric
59+ deriving (Eq, Show)
60+
61+data Solved = Solved
62+ { _schema :: Schema Id
63+ , _type :: TType
64+ , _deriving :: [Derive]
65+ }
66+
67+instance HasInfo Solved where
68+ info = f . info
69+ where
70+ f = lens _schema (\s a -> s { _schema = a })
71+
3872data Memo = Memo
3973 { _typed :: Map Id TType
4074 , _derived :: Map Id [Derive]
4175 , _schemas :: Map Id (Schema Id)
4276 }
4377
44−initial :: Memo
45−initial = Memo mempty mempty mempty
78+initial :: Map Id (Schema Id) -> Memo
79+initial = Memo mempty mempty
4680
4781makeLenses ''Memo
4882
4983type AST = ExceptT Error (State Memo)
5084
51−-- runAST :: AST a -> Either Error a
52−-- runAST m = evalState (runExceptT m) initial
53−
5485schema :: Id -> AST (Schema Id)
5586schema k = do
5687 m <- gets (Map.lookup k . view schemas)
gen/src/Gen/Syntax.hs+33−33
@@ -15,6 +15,7 @@ module Gen.Syntax where
1515
1616import Control.Lens hiding (iso, mapping, op, strict)
1717import Data.Foldable (foldr')
18+import Data.Hashable
1819import qualified Data.HashMap.Strict as Map
1920import Data.Maybe
2021import Data.Semigroup ((<>))
@@ -29,30 +30,30 @@ import Language.Haskell.Exts.Build
2930import Language.Haskell.Exts.SrcLoc
3031import Language.Haskell.Exts.Syntax hiding (Int)
3132
33+instance Hashable Name
34+
3235instance IsString Name where fromString = name
3336instance IsString QName where fromString = UnQual . name
3437instance IsString QOp where fromString = op . sym
3538
36−apiTypes :: Service s p r
37− -> Map Id (Param Solved)
38− -> Id
39− -> Method Solved
40− -> [Type]
41−apiTypes s qps r m = map sing ps ++ qs ++ [end]
39+apiTypes :: Service s r -> Id -> Method -> [Type]
40+apiTypes s r m = map sing ps ++ qs ++ [end]
4241 where
4342 ps = filter (not . Text.null)
4443 $ Text.split (== '/') (_svcServicePath s)
4544 <> Text.split (== '/') (_mPath m)
4645
4746 -- FIXME: order by _mParameterOrder
48− qs = map param (Map.toList qps)
49− ++ map param (Map.toList (_mParameters m))
47+ qs = map param (Map.toList (_svcParameters s))
48+ ++ map param (Map.toList (_mParameters m))
5049
51− param (k, Param l _ t) =
50+ param (k, p) =
5251 -- FIXME: types, many/repeated
53− case l of
54− Path -> TyApp (TyApp (tycon "Capture") (sing (idToText k))) (external (_type t))
55− Query -> TyApp (TyApp (tycon "QueryParam") (sing (idToText k))) (external (_type t))
52+ let t = literal (_prmLiteral p)
53+ n = sing (idToText k)
54+ in case _prmLocation p of
55+ Path -> TyApp (TyApp (tycon "Capture") n) t
56+ Query -> TyApp (TyApp (tycon "QueryParam") n) t
5657
5758 end = TyApp (TyApp meth typ) res
5859
@@ -142,27 +143,26 @@ parameters = map (external . _type) . filter (view required)
142143
143144external, internal :: TType -> Type
144145external = internal
145−internal = go
146− where
147− go = \case
148− TType r -> tycon r
149− TMaybe t -> TyApp (tycon "Maybe") (go t)
150− TEither a b -> TyApp (TyApp (tycon "Either") (go a)) (go b)
151− TList t -> TyList (go t)
152− TLit l -> lit l
153−
154− lit = \case
155− Text -> tycon "Text"
156− Bool -> tycon "Bool"
157− Time -> tycon "UTCTime"
158− Nat -> tycon "Natural"
159− Float -> tycon "Float"
160− Double -> tycon "Double"
161− Byte -> tycon "Word8"
162− UInt32 -> tycon "Word32"
163− UInt64 -> tycon "Word64"
164− Int32 -> tycon "Int32"
165− Int64 -> tycon "Int64"
146+internal = \case
147+ TType r -> tycon r
148+ TMaybe t -> TyApp (tycon "Maybe") (internal t)
149+ TEither a b -> TyApp (TyApp (tycon "Either") (internal a)) (internal b)
150+ TList t -> TyList (internal t)
151+ TLit l -> literal l
152+
153+literal :: Lit -> Type
154+literal = \case
155+ Text -> tycon "Text"
156+ Bool -> tycon "Bool"
157+ Time -> tycon "UTCTime"
158+ Nat -> tycon "Natural"
159+ Float -> tycon "Float"
160+ Double -> tycon "Double"
161+ Byte -> tycon "Word8"
162+ UInt32 -> tycon "Word32"
163+ UInt64 -> tycon "Word64"
164+ Int32 -> tycon "Int32"
165+ Int64 -> tycon "Int64"
166166
167167mapping :: TType -> Exp -> Exp
168168mapping t e = infixE e "." (go t)
gen/src/Gen/Types.hs+27−58
@@ -34,8 +34,10 @@ import Control.Applicative
3434import Control.Lens hiding ((.=))
3535import Data.Aeson hiding (Bool, String)
3636import Data.Aeson.TH
37+import Data.Bifunctor
3738import Data.Char
3839import Data.Function (on)
40+import qualified Data.HashMap.Strict as Map
3941import Data.List.NonEmpty (NonEmpty (..))
4042import qualified Data.List.NonEmpty as NE
4143import Data.Maybe
@@ -125,8 +127,6 @@ specFromPath x = Spec n p v x
125127 p = toTextIgnore (Path.parent (Path.parent x))
126128 v = toTextIgnore (Path.dirname x)
127129
128−
129−
130130data Protocol = REST
131131 deriving (Eq, Show)
132132
@@ -257,14 +257,19 @@ instance HasInfo (Schema a) where
257257 Ref _ r -> Ref i r
258258 Any {} -> Any i
259259
260−data Param a = Param !Location !Bool a
261− deriving (Functor, Foldable, Traversable)
260+data Param = Param
261+ { _prmLocation :: !Location
262+ , _prmRepeated :: !Bool
263+ , _prmInfo :: Info
264+ , _prmLiteral :: !Lit
265+ }
262266
263−instance FromJSON a => FromJSON (Param a) where
267+instance FromJSON Param where
264268 parseJSON = withObject "parameter" $ \o -> Param
265269 <$> o .: "location"
266270 <*> o .:? "repeated" .!= False
267271 <*> parseJSON (Object o)
272+ <*> parseJSON (Object o)
268273
269274deriveToJSON (js "") ''Param
270275
@@ -305,63 +310,27 @@ instance ToJSON Data where
305310 , "lenses" .= ls
306311 ]
307312
308−
309−data TType
310− = TType Id
311− | TLit Lit
312− | TMaybe TType
313− | TEither TType TType
314− | TList TType
315−
316−data Derive
317− = DEq
318− | DOrd
319− | DRead
320− | DShow
321− | DEnum
322− | DNum
323− | DIntegral
324− | DReal
325− | DMonoid
326− | DIsString
327− | DData
328− | DTypeable
329− | DGeneric
330− deriving (Eq, Show)
331−
332−data Solved = Solved
333− { _schema :: Schema Id
334− , _type :: TType
335− , _deriving :: [Derive]
336− }
337−
338−instance HasInfo Solved where
339− info = f . info
340− where
341− f = lens _schema (\s a -> s { _schema = a })
342−
343−deriveToJSON (js "T") ''TType
344−deriveToJSON (js "D") ''Derive
345−deriveToJSON (js "_") ''Solved
346−
347−data API = API Name [Rendered]
313+data API = API Name (Map Name [Rendered])
348314
349315instance ToJSON API where
350− toJSON (API n d) = object ["name" .= Syn n, "types" .= d]
316+ toJSON (API n ms) = object
317+ [ "name" .= Syn n
318+ , "methods" .= Map.fromList (map (first prettyPrint) $ Map.toList ms)
319+ ]
351320
352−data Method a = Method
321+data Method = Method
353322 { _mId :: Text
354323 , _mPath :: Text
355324 , _mMethod :: Text
356325 , _mDescription :: Maybe Help
357− , _mParameters :: Map Id (Param a)
326+ , _mParameters :: Map Id Param
358327 , _mParameterOrder :: [Id]
359328 , _mScopes :: [Text]
360329 , _mRequest :: Maybe Id
361330 , _mResponse :: Maybe Id
362331 } deriving (Generic)
363332
364−instance FromJSON a => FromJSON (Method a) where
333+instance FromJSON Method where
365334 parseJSON = withObject "method" $ \o -> Method
366335 <$> o .: "id"
367336 <*> o .: "path"
@@ -378,11 +347,11 @@ instance FromJSON a => FromJSON (Method a) where
378347
379348deriveToJSON (js "_m") ''Method
380349
381−newtype Resource a = Resource { methods :: Map Id (Method a) }
350+newtype Resource = Resource { methods :: Map Id Method }
382351
383352deriveFromJSON (js "") ''Resource
384353
385−data Service s p r = Service
354+data Service s r = Service
386355 { _svcLibrary :: Text
387356 , _svcTitle :: Text
388357 , _svcName :: Text
@@ -400,14 +369,14 @@ data Service s p r = Service
400369 , _svcServicePath :: Text
401370 , _svcBatchPath :: Text
402371 , _svcAuth :: Maybe Object
403− , _svcParameters :: Map Id (Param p)
372+ , _svcParameters :: Map Id Param
404373 , _svcSchemas :: Map Id s
405374 , _svcResources :: Map Id r
406375 } deriving (Generic)
407376
408377deriveFromJSON (js "_svc") ''Service
409378
410−instance ToJSON p => ToJSON (Service Data p API) where
379+instance ToJSON (Service Data API) where
411380 toJSON s = Object (x <> y)
412381 where
413382 Object x = genericToJSON (js "_svc") s
@@ -416,24 +385,24 @@ instance ToJSON p => ToJSON (Service Data p API) where
416385 , "api" .= Syn (aname (idFromText (_svcName s)))
417386 ]
418387
419−svcAbbrev :: Service s p r -> Text
388+svcAbbrev :: Service s r -> Text
420389svcAbbrev = renameAbbrev . _svcTitle
421390
422−typeImports :: Service s p r -> [NS]
391+typeImports :: Service s r -> [NS]
423392typeImports _ = ["Network.Google.Prelude"]
424393
425−tocNS, typesNS :: Service s p r -> NS
394+tocNS, typesNS :: Service s r -> NS
426395tocNS s = NS ["Network", "Google", svcAbbrev s]
427396typesNS = (<> "Types") . tocNS
428397
429−exposedModules :: Service s p r -> [NS]
398+exposedModules :: Service s r -> [NS]
430399exposedModules s = [tocNS s, typesNS s]
431400
432401data Library = Library
433402 { _libName :: Text
434403 , _libTitle :: Text
435404 , _libVersions :: Versions
436− , _libServices :: NonEmpty (Service Data Solved API)
405+ , _libServices :: NonEmpty (Service Data API)
437406 }
438407
439408instance ToJSON Library where
gen/src/Gen/Types/Id.hs+9−3
@@ -22,6 +22,7 @@ module Gen.Types.Id
2222
2323 -- * Syntax
2424 , aname
25+ , mname
2526 , dname
2627 , cname
2728 , fname
@@ -55,8 +56,13 @@ import GHC.Generics
5556import Language.Haskell.Exts.Build
5657import Language.Haskell.Exts.Syntax (Name)
5758
58−aname, dname, cname, fname, lname, pname :: Id -> Name
59+aname :: Id -> Name
5960aname = name . ref upperHead
61+
62+mname :: Id -> Id -> Name
63+mname p k = aname (p <> k)
64+
65+dname, cname, fname, lname, pname :: Id -> Name
6066dname = name . ref upperHead
6167cname = name . ref (renameReserved . lowerHead)
6268fname = name . ref (Text.cons '_' . lowerHead)
@@ -94,12 +100,12 @@ instance ToJSON a => ToJSON (Map Id a) where
94100 toJSON = toJSON . Map.fromList . map (first idToText) . Map.toList
95101
96102idToText :: Id -> Text
97−idToText = \case
103+idToText = renameReserved . \case
98104 Opaque xs -> mconcat (map upperHead xs)
99105 Direct n -> n
100106
101107idFromText :: Text -> Id
102−idFromText = Direct . renameReserved
108+idFromText = Direct
103109
104110fid :: Format a (Id -> a)
105111fid = later (Build.fromText . idToText)
gen/src/Main.hs+2−1
@@ -27,6 +27,7 @@ import Gen.AST
2727import Gen.Formatting
2828import Gen.IO
2929import qualified Gen.JSON as JS
30+import Gen.Solve
3031import qualified Gen.Tree as Tree
3132import Gen.Types hiding (info)
3233import Options.Applicative
@@ -158,7 +159,7 @@ main = do
158159
159160 return s
160161
161− libs <- hoistEither (runAST _optVersions svcs)
162+ libs <- merge _optVersions <$> traverse (hoistEither . runAST) svcs
162163
163164 void . counter "library" libs $ \l -> do
164165 say ("Creating " % stext % " package.") (_libTitle l)
gen/template/toc.ede+19−8
@@ -7,13 +7,17 @@ module {{ moduleName }}
77 (
88 -- * API Definition
99 {{ api }}
10− , {{ api | lowerHead }}API
10+ , {{ api | lowerHead }}
1111
1212 -- * Resources
1313 -- $resources
14−
1514 {% for resource in resources %}
15+
16+ -- ** {{ resource.value.name }}
1617 , {{ resource.value.name }}
18+ {% for method in resource.value.methods %}
19+ , {{ method.key }}
20+ {% endfor %}
1721 {% endfor %}
1822
1923 -- * Types
@@ -45,17 +49,24 @@ import {{ module.value }}
4549TODO
4650-}
4751
52+{{ api | lowerHead }} :: Proxy {{ api }}
53+{{ api | lowerHead }} = Proxy
54+
4855type {{ api }} =
4956{% for resource in resources %}
50− {% if resource.first %} {% else %}:<|>{% endif %} {{ resource.value.name }}
57+ {% if resource.first %} {% else %}:<|>{% endif %} {{ resource.value.name }}
5158{% endfor %}
52−
53−{{ api | lowerHead }}API :: Proxy {{ api }}
54−{{ api | lowerHead }}API = Proxy
5559{% for resource in resources %}
5660
5761type {{ resource.value.name }} =
58− {% for type in resource.value.types %}
59− {% if type.first %} {% else %}:>{% endif %} {{ type.value }}
62+ {% for method in resource.value.methods %}
63+ {% if !method.first %}:<|>{% else %} {% endif %} {{ method.key }}
64+ {% endfor %}
65+ {% for method in resource.value.methods %}
66+
67+type {{ method.key }} =
68+ {% for type in method.value %}
69+ {% if !type.first %}:>{% else %} {% endif %} {{ type.value }}
70+ {% endfor %}
6071 {% endfor %}
6172{% endfor %}