git.iko.soy/gogol
on develop help sign in
Rendering resource methods as separate type aliases to reduce noise/haddock explosion
f9920b0Brendan Hay
gen/gozen-gen.cabal+1
compare with develop
unifiedsplit
@@ -43,6 +43,7 @@ executable gozen-gen
43 , bytestring
43 , bytestring
44 , directory-tree
44 , directory-tree
45 , ede
45 , ede
46+ , bifunctors
46 , errors
47 , errors
47 , formatting
48 , formatting
48 , hashable
49 , hashable
gen/src/Gen/AST.hs+43−78
@@ -1,4 +1,5 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
@@ -24,7 +25,7 @@ import Control.Applicative
24import Control.Error
25import Control.Error
25import Control.Lens hiding (lens)
26import Control.Lens hiding (lens)
26import Control.Monad.Except
27import Control.Monad.Except
27−import Control.Monad.State
28+import Control.Monad.State.Strict
28import Data.Char
29import Data.Char
29import Data.Function (on)
30import Data.Function (on)
30import qualified Data.HashMap.Strict as Map
31import qualified Data.HashMap.Strict as Map
@@ -42,73 +43,16 @@ import HIndent
42import Language.Haskell.Exts.Pretty
43import Language.Haskell.Exts.Pretty
43import Prelude hiding (sum)
44import Prelude hiding (sum)
44
45
45−runAST :: Versions
46− -> [Service (Fix Schema) (Fix Schema) (Resource (Fix Schema))]
46+--runAST :: Service (Schema Id) Resource -> Either Error a
47− -> Either Error [Library]
48−runAST v ss = merge v <$> evalState (runExceptT go) initial
47+runAST svc = evalState (runExceptT (render ss)) (initial (_svcSchemas ss))
49 where
48 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
49+ ss = flatten svc
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
86
50
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)
107render svc = do
52render svc = do
108− x <- kvTraverseMaybe typ (_svcSchemas svc)
53+ x <- kvTraverseMaybe typ (_svcSchemas svc)
109− y <- Map.traverseWithKey prm (_svcParameters svc)
54+ y <- Map.traverseWithKey api (_svcResources svc)
110− z <- Map.traverseWithKey (api y) (_svcResources svc)
111− return $! svc { _svcSchemas = x, _svcParameters = y, _svcResources = z }
55+ return $! svc { _svcSchemas = x, _svcResources = y }
112 where
56 where
113 typ :: Id -> Schema Id -> AST (Maybe Data)
57 typ :: Id -> Schema Id -> AST (Maybe Data)
114 typ k = \case
58 typ k = \case
@@ -140,24 +84,45 @@ render svc = do
140 sformat ("Creates a value of '" % fid %
84 sformat ("Creates a value of '" % fid %
141 "' with the minimum fields required to make a request.\n")
85 "' with the minimum fields required to make a request.\n")
142 k
86 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
143
105
144−Make param types lit only, and fail at json parse time?
106+ Arr i (Fix e) -> do
145−Then avoid any solving/id memo steps.
107+ e' <- prop (Just this) "item" (Fix (e & required .~ True))
108+ res (Arr i e')
146
109
147− prm :: Id -> Param (Schema Id) -> AST (Param Solved)
110+ Enum i vs ds -> res (Enum i vs ds)
148− prm r p = do
111+ Lit i l -> res (Lit i l)
149− let k = "param" <> r
112+ Ref _ r -> pure r
150− traverse (const (solve k)) p
113+ Any i -> res (Any i)
151
114
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 }))
157 where
115 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
159
124
160−merge :: Versions -> [Service Data Solved API] -> [Library]
125+merge :: Versions -> [Service Data API] -> [Library]
161merge v = map go . groupBy (on (==) _svcLibrary)
126merge v = map go . groupBy (on (==) _svcLibrary)
162 where
127 where
163 go [x] = mk x
128 go [x] = mk x
gen/src/Gen/Solve.hs+42−11
@@ -21,36 +21,67 @@ module Gen.Solve where
21
21
22import Control.Applicative
22import Control.Applicative
23import Control.Error
23import Control.Error
24−import Control.Lens hiding (enum)
24+import Control.Lens hiding (enum)
25import Control.Monad.Except
25import Control.Monad.Except
26−import Control.Monad.State
26+import Control.Monad.State.Strict
27−import qualified Data.HashMap.Strict as Map
27+import qualified Data.HashMap.Strict as Map
28−import Data.List (intersect)
28+import Data.List (intersect)
29import Data.Maybe
29import Data.Maybe
30−import Data.Semigroup ((<>))
30+import Data.Semigroup ((<>))
31import Gen.Formatting
31import Gen.Formatting
32import Gen.Types
32import Gen.Types
33−import Prelude hiding (sum)
33+import Prelude hiding (sum)
34
34
35-- Just use hashmaps to lookup refs etc, and hide all the mutation
35-- Just use hashmaps to lookup refs etc, and hide all the mutation
36-- behind a StateT interface.
36-- behind a StateT interface.
37
37
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+
38data Memo = Memo
72data Memo = Memo
39 { _typed :: Map Id TType
73 { _typed :: Map Id TType
40 , _derived :: Map Id [Derive]
74 , _derived :: Map Id [Derive]
41 , _schemas :: Map Id (Schema Id)
75 , _schemas :: Map Id (Schema Id)
42 }
76 }
43
77
44−initial :: Memo
78+initial :: Map Id (Schema Id) -> Memo
45−initial = Memo mempty mempty mempty
79+initial = Memo mempty mempty
46
80
47makeLenses ''Memo
81makeLenses ''Memo
48
82
49type AST = ExceptT Error (State Memo)
83type AST = ExceptT Error (State Memo)
50
84
51−-- runAST :: AST a -> Either Error a
52−-- runAST m = evalState (runExceptT m) initial
53−
54schema :: Id -> AST (Schema Id)
85schema :: Id -> AST (Schema Id)
55schema k = do
86schema k = do
56 m <- gets (Map.lookup k . view schemas)
87 m <- gets (Map.lookup k . view schemas)
gen/src/Gen/Syntax.hs+33−33
@@ -15,6 +15,7 @@ module Gen.Syntax where
15
15
16import Control.Lens hiding (iso, mapping, op, strict)
16import Control.Lens hiding (iso, mapping, op, strict)
17import Data.Foldable (foldr')
17import Data.Foldable (foldr')
18+import Data.Hashable
18import qualified Data.HashMap.Strict as Map
19import qualified Data.HashMap.Strict as Map
19import Data.Maybe
20import Data.Maybe
20import Data.Semigroup ((<>))
21import Data.Semigroup ((<>))
@@ -29,30 +30,30 @@ import Language.Haskell.Exts.Build
29import Language.Haskell.Exts.SrcLoc
30import Language.Haskell.Exts.SrcLoc
30import Language.Haskell.Exts.Syntax hiding (Int)
31import Language.Haskell.Exts.Syntax hiding (Int)
31
32
33+instance Hashable Name
34+
32instance IsString Name where fromString = name
35instance IsString Name where fromString = name
33instance IsString QName where fromString = UnQual . name
36instance IsString QName where fromString = UnQual . name
34instance IsString QOp where fromString = op . sym
37instance IsString QOp where fromString = op . sym
35
38
36−apiTypes :: Service s p r
39+apiTypes :: Service s r -> Id -> Method -> [Type]
37− -> Map Id (Param Solved)
38− -> Id
39− -> Method Solved
40− -> [Type]
41−apiTypes s qps r m = map sing ps ++ qs ++ [end]
40+apiTypes s r m = map sing ps ++ qs ++ [end]
42 where
41 where
43 ps = filter (not . Text.null)
42 ps = filter (not . Text.null)
44 $ Text.split (== '/') (_svcServicePath s)
43 $ Text.split (== '/') (_svcServicePath s)
45 <> Text.split (== '/') (_mPath m)
44 <> Text.split (== '/') (_mPath m)
46
45
47 -- FIXME: order by _mParameterOrder
46 -- FIXME: order by _mParameterOrder
48− qs = map param (Map.toList qps)
47+ qs = map param (Map.toList (_svcParameters s))
49− ++ map param (Map.toList (_mParameters m))
48+ ++ map param (Map.toList (_mParameters m))
50
49
51− param (k, Param l _ t) =
50+ param (k, p) =
52 -- FIXME: types, many/repeated
51 -- FIXME: types, many/repeated
52+ let t = literal (_prmLiteral p)
53+ n = sing (idToText k)
53− case l of
54+ in case _prmLocation p of
54− Path -> TyApp (TyApp (tycon "Capture") (sing (idToText k))) (external (_type t))
55+ Path -> TyApp (TyApp (tycon "Capture") n) t
55− Query -> TyApp (TyApp (tycon "QueryParam") (sing (idToText k))) (external (_type t))
56+ Query -> TyApp (TyApp (tycon "QueryParam") n) t
56
57
57 end = TyApp (TyApp meth typ) res
58 end = TyApp (TyApp meth typ) res
58
59
@@ -142,27 +143,26 @@ parameters = map (external . _type) . filter (view required)
142
143
143external, internal :: TType -> Type
144external, internal :: TType -> Type
144external = internal
145external = internal
145−internal = go
146+internal = \case
146− where
147− go = \case
148− TType r -> tycon r
147+ TType r -> tycon r
149− TMaybe t -> TyApp (tycon "Maybe") (go t)
148+ TMaybe t -> TyApp (tycon "Maybe") (internal t)
150− TEither a b -> TyApp (TyApp (tycon "Either") (go a)) (go b)
149+ TEither a b -> TyApp (TyApp (tycon "Either") (internal a)) (internal b)
151− TList t -> TyList (go t)
150+ TList t -> TyList (internal t)
152− TLit l -> lit l
151+ TLit l -> literal l
153−
152+
153+literal :: Lit -> Type
154− lit = \case
154+literal = \case
155− Text -> tycon "Text"
155+ Text -> tycon "Text"
156− Bool -> tycon "Bool"
156+ Bool -> tycon "Bool"
157− Time -> tycon "UTCTime"
157+ Time -> tycon "UTCTime"
158− Nat -> tycon "Natural"
158+ Nat -> tycon "Natural"
159− Float -> tycon "Float"
159+ Float -> tycon "Float"
160− Double -> tycon "Double"
160+ Double -> tycon "Double"
161− Byte -> tycon "Word8"
161+ Byte -> tycon "Word8"
162− UInt32 -> tycon "Word32"
162+ UInt32 -> tycon "Word32"
163− UInt64 -> tycon "Word64"
163+ UInt64 -> tycon "Word64"
164− Int32 -> tycon "Int32"
164+ Int32 -> tycon "Int32"
165− Int64 -> tycon "Int64"
165+ Int64 -> tycon "Int64"
166
166
167mapping :: TType -> Exp -> Exp
167mapping :: TType -> Exp -> Exp
168mapping t e = infixE e "." (go t)
168mapping t e = infixE e "." (go t)
gen/src/Gen/Types.hs+27−58
@@ -34,8 +34,10 @@ import Control.Applicative
34import Control.Lens hiding ((.=))
34import Control.Lens hiding ((.=))
35import Data.Aeson hiding (Bool, String)
35import Data.Aeson hiding (Bool, String)
36import Data.Aeson.TH
36import Data.Aeson.TH
37+import Data.Bifunctor
37import Data.Char
38import Data.Char
38import Data.Function (on)
39import Data.Function (on)
40+import qualified Data.HashMap.Strict as Map
39import Data.List.NonEmpty (NonEmpty (..))
41import Data.List.NonEmpty (NonEmpty (..))
40import qualified Data.List.NonEmpty as NE
42import qualified Data.List.NonEmpty as NE
41import Data.Maybe
43import Data.Maybe
@@ -125,8 +127,6 @@ specFromPath x = Spec n p v x
125 p = toTextIgnore (Path.parent (Path.parent x))
127 p = toTextIgnore (Path.parent (Path.parent x))
126 v = toTextIgnore (Path.dirname x)
128 v = toTextIgnore (Path.dirname x)
127
129
128−
129−
130data Protocol = REST
130data Protocol = REST
131 deriving (Eq, Show)
131 deriving (Eq, Show)
132
132
@@ -257,14 +257,19 @@ instance HasInfo (Schema a) where
257 Ref _ r -> Ref i r
257 Ref _ r -> Ref i r
258 Any {} -> Any i
258 Any {} -> Any i
259
259
260−data Param a = Param !Location !Bool a
260+data Param = Param
261− deriving (Functor, Foldable, Traversable)
261+ { _prmLocation :: !Location
262+ , _prmRepeated :: !Bool
263+ , _prmInfo :: Info
264+ , _prmLiteral :: !Lit
265+ }
262
266
263−instance FromJSON a => FromJSON (Param a) where
267+instance FromJSON Param where
264 parseJSON = withObject "parameter" $ \o -> Param
268 parseJSON = withObject "parameter" $ \o -> Param
265 <$> o .: "location"
269 <$> o .: "location"
266 <*> o .:? "repeated" .!= False
270 <*> o .:? "repeated" .!= False
267 <*> parseJSON (Object o)
271 <*> parseJSON (Object o)
272+ <*> parseJSON (Object o)
268
273
269deriveToJSON (js "") ''Param
274deriveToJSON (js "") ''Param
270
275
@@ -305,63 +310,27 @@ instance ToJSON Data where
305 , "lenses" .= ls
310 , "lenses" .= ls
306 ]
311 ]
307
312
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])
348
314
349instance ToJSON API where
315instance 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+ ]
351
320
352−data Method a = Method
321+data Method = Method
353 { _mId :: Text
322 { _mId :: Text
354 , _mPath :: Text
323 , _mPath :: Text
355 , _mMethod :: Text
324 , _mMethod :: Text
356 , _mDescription :: Maybe Help
325 , _mDescription :: Maybe Help
357− , _mParameters :: Map Id (Param a)
326+ , _mParameters :: Map Id Param
358 , _mParameterOrder :: [Id]
327 , _mParameterOrder :: [Id]
359 , _mScopes :: [Text]
328 , _mScopes :: [Text]
360 , _mRequest :: Maybe Id
329 , _mRequest :: Maybe Id
361 , _mResponse :: Maybe Id
330 , _mResponse :: Maybe Id
362 } deriving (Generic)
331 } deriving (Generic)
363
332
364−instance FromJSON a => FromJSON (Method a) where
333+instance FromJSON Method where
365 parseJSON = withObject "method" $ \o -> Method
334 parseJSON = withObject "method" $ \o -> Method
366 <$> o .: "id"
335 <$> o .: "id"
367 <*> o .: "path"
336 <*> o .: "path"
@@ -378,11 +347,11 @@ instance FromJSON a => FromJSON (Method a) where
378
347
379deriveToJSON (js "_m") ''Method
348deriveToJSON (js "_m") ''Method
380
349
381−newtype Resource a = Resource { methods :: Map Id (Method a) }
350+newtype Resource = Resource { methods :: Map Id Method }
382
351
383deriveFromJSON (js "") ''Resource
352deriveFromJSON (js "") ''Resource
384
353
385−data Service s p r = Service
354+data Service s r = Service
386 { _svcLibrary :: Text
355 { _svcLibrary :: Text
387 , _svcTitle :: Text
356 , _svcTitle :: Text
388 , _svcName :: Text
357 , _svcName :: Text
@@ -400,14 +369,14 @@ data Service s p r = Service
400 , _svcServicePath :: Text
369 , _svcServicePath :: Text
401 , _svcBatchPath :: Text
370 , _svcBatchPath :: Text
402 , _svcAuth :: Maybe Object
371 , _svcAuth :: Maybe Object
403− , _svcParameters :: Map Id (Param p)
372+ , _svcParameters :: Map Id Param
404 , _svcSchemas :: Map Id s
373 , _svcSchemas :: Map Id s
405 , _svcResources :: Map Id r
374 , _svcResources :: Map Id r
406 } deriving (Generic)
375 } deriving (Generic)
407
376
408deriveFromJSON (js "_svc") ''Service
377deriveFromJSON (js "_svc") ''Service
409
378
410−instance ToJSON p => ToJSON (Service Data p API) where
379+instance ToJSON (Service Data API) where
411 toJSON s = Object (x <> y)
380 toJSON s = Object (x <> y)
412 where
381 where
413 Object x = genericToJSON (js "_svc") s
382 Object x = genericToJSON (js "_svc") s
@@ -416,24 +385,24 @@ instance ToJSON p => ToJSON (Service Data p API) where
416 , "api" .= Syn (aname (idFromText (_svcName s)))
385 , "api" .= Syn (aname (idFromText (_svcName s)))
417 ]
386 ]
418
387
419−svcAbbrev :: Service s p r -> Text
388+svcAbbrev :: Service s r -> Text
420svcAbbrev = renameAbbrev . _svcTitle
389svcAbbrev = renameAbbrev . _svcTitle
421
390
422−typeImports :: Service s p r -> [NS]
391+typeImports :: Service s r -> [NS]
423typeImports _ = ["Network.Google.Prelude"]
392typeImports _ = ["Network.Google.Prelude"]
424
393
425−tocNS, typesNS :: Service s p r -> NS
394+tocNS, typesNS :: Service s r -> NS
426tocNS s = NS ["Network", "Google", svcAbbrev s]
395tocNS s = NS ["Network", "Google", svcAbbrev s]
427typesNS = (<> "Types") . tocNS
396typesNS = (<> "Types") . tocNS
428
397
429−exposedModules :: Service s p r -> [NS]
398+exposedModules :: Service s r -> [NS]
430exposedModules s = [tocNS s, typesNS s]
399exposedModules s = [tocNS s, typesNS s]
431
400
432data Library = Library
401data Library = Library
433 { _libName :: Text
402 { _libName :: Text
434 , _libTitle :: Text
403 , _libTitle :: Text
435 , _libVersions :: Versions
404 , _libVersions :: Versions
436− , _libServices :: NonEmpty (Service Data Solved API)
405+ , _libServices :: NonEmpty (Service Data API)
437 }
406 }
438
407
439instance ToJSON Library where
408instance ToJSON Library where
gen/src/Gen/Types/Id.hs+9−3
@@ -22,6 +22,7 @@ module Gen.Types.Id
22
22
23 -- * Syntax
23 -- * Syntax
24 , aname
24 , aname
25+ , mname
25 , dname
26 , dname
26 , cname
27 , cname
27 , fname
28 , fname
@@ -55,8 +56,13 @@ import GHC.Generics
55import Language.Haskell.Exts.Build
56import Language.Haskell.Exts.Build
56import Language.Haskell.Exts.Syntax (Name)
57import Language.Haskell.Exts.Syntax (Name)
57
58
58−aname, dname, cname, fname, lname, pname :: Id -> Name
59+aname :: Id -> Name
59aname = name . ref upperHead
60aname = 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
60dname = name . ref upperHead
66dname = name . ref upperHead
61cname = name . ref (renameReserved . lowerHead)
67cname = name . ref (renameReserved . lowerHead)
62fname = name . ref (Text.cons '_' . lowerHead)
68fname = name . ref (Text.cons '_' . lowerHead)
@@ -94,12 +100,12 @@ instance ToJSON a => ToJSON (Map Id a) where
94 toJSON = toJSON . Map.fromList . map (first idToText) . Map.toList
100 toJSON = toJSON . Map.fromList . map (first idToText) . Map.toList
95
101
96idToText :: Id -> Text
102idToText :: Id -> Text
97−idToText = \case
103+idToText = renameReserved . \case
98 Opaque xs -> mconcat (map upperHead xs)
104 Opaque xs -> mconcat (map upperHead xs)
99 Direct n -> n
105 Direct n -> n
100
106
101idFromText :: Text -> Id
107idFromText :: Text -> Id
102−idFromText = Direct . renameReserved
108+idFromText = Direct
103
109
104fid :: Format a (Id -> a)
110fid :: Format a (Id -> a)
105fid = later (Build.fromText . idToText)
111fid = later (Build.fromText . idToText)
gen/src/Main.hs+2−1
@@ -27,6 +27,7 @@ import Gen.AST
27import Gen.Formatting
27import Gen.Formatting
28import Gen.IO
28import Gen.IO
29import qualified Gen.JSON as JS
29import qualified Gen.JSON as JS
30+import Gen.Solve
30import qualified Gen.Tree as Tree
31import qualified Gen.Tree as Tree
31import Gen.Types hiding (info)
32import Gen.Types hiding (info)
32import Options.Applicative
33import Options.Applicative
@@ -158,7 +159,7 @@ main = do
158
159
159 return s
160 return s
160
161
161− libs <- hoistEither (runAST _optVersions svcs)
162+ libs <- merge _optVersions <$> traverse (hoistEither . runAST) svcs
162
163
163 void . counter "library" libs $ \l -> do
164 void . counter "library" libs $ \l -> do
164 say ("Creating " % stext % " package.") (_libTitle l)
165 say ("Creating " % stext % " package.") (_libTitle l)
gen/template/toc.ede+19−8
@@ -7,13 +7,17 @@ module {{ moduleName }}
7 (
7 (
8 -- * API Definition
8 -- * API Definition
9 {{ api }}
9 {{ api }}
10− , {{ api | lowerHead }}API
10+ , {{ api | lowerHead }}
11
11
12 -- * Resources
12 -- * Resources
13 -- $resources
13 -- $resources
14−
15 {% for resource in resources %}
14 {% for resource in resources %}
15+
16+ -- ** {{ resource.value.name }}
16 , {{ resource.value.name }}
17 , {{ resource.value.name }}
18+ {% for method in resource.value.methods %}
19+ , {{ method.key }}
20+ {% endfor %}
17 {% endfor %}
21 {% endfor %}
18
22
19 -- * Types
23 -- * Types
@@ -45,17 +49,24 @@ import {{ module.value }}
45TODO
49TODO
46-}
50-}
47
51
52+{{ api | lowerHead }} :: Proxy {{ api }}
53+{{ api | lowerHead }} = Proxy
54+
48type {{ api }} =
55type {{ api }} =
49{% for resource in resources %}
56{% for resource in resources %}
50− {% if resource.first %} {% else %}:<|>{% endif %} {{ resource.value.name }}
57+ {% if resource.first %} {% else %}:<|>{% endif %} {{ resource.value.name }}
51{% endfor %}
58{% endfor %}
52−
53−{{ api | lowerHead }}API :: Proxy {{ api }}
54−{{ api | lowerHead }}API = Proxy
55{% for resource in resources %}
59{% for resource in resources %}
56
60
57type {{ resource.value.name }} =
61type {{ resource.value.name }} =
58− {% for type in resource.value.types %}
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 %}
59− {% if type.first %} {% else %}:>{% endif %} {{ type.value }}
69+ {% if !type.first %}:>{% else %} {% endif %} {{ type.value }}
70+ {% endfor %}
60 {% endfor %}
71 {% endfor %}
61{% endfor %}
72{% endfor %}