git.iko.soy/gogol
on develop help sign in
Reworking to support JSON Schema specification
commit3903e2e0bbb6921fd0d007a6e7ae4ea8693b230e authorBrendan Hay <brendan.g.hay@gmail.com> dateTue 29 Sep 2015, 12:31 (11 years ago) parentee014ec
14 files changed+1284−1143
compare with develop
unifiedsplit
gen/gogol-gen.cabal+15−14 gen/src/Gen/AST.hs+228−227 gen/src/Gen/AST/Flatten.hs+156 gen/src/Gen/Names.hs+9 gen/src/Gen/Orphans.hs+1 gen/src/Gen/Schema.hs−336 gen/src/Gen/Solve.hs+4−22 gen/src/Gen/TH.hs+27 gen/src/Gen/Types.hs+130−441 gen/src/Gen/Types/Data.hs+154 gen/src/Gen/Types/Id.hs+47−85 gen/src/Gen/Types/Map.hs+20−1 gen/src/Gen/Types/NS.hs+4−17 gen/src/Gen/Types/Schema.hs+489
gen/gogol-gen.cabal+15−14
@@ -22,20 +22,21 @@ executable gogol-gen
2222
2323 other-modules:
2424 Gen.AST
25− , Gen.Formatting
26− , Gen.IO
27− , Gen.JSON
28− , Gen.Orphans
29− , Gen.Schema
30− , Gen.Solve
31− , Gen.Syntax
32− , Gen.Text
33− , Gen.Tree
34− , Gen.Types
35− , Gen.Types.Help
36− , Gen.Types.Id
37− , Gen.Types.Map
38− , Gen.Types.NS
25+ -- , Gen.Formatting
26+ -- , Gen.IO
27+ -- , Gen.JSON
28+ -- , Gen.Orphans
29+ -- , Gen.Schema
30+ -- , Gen.Solve
31+ -- , Gen.Syntax
32+ -- , Gen.Text
33+ -- , Gen.TH
34+ -- , Gen.Tree
35+ -- , Gen.Types
36+ -- , Gen.Types.Help
37+ -- , Gen.Types.Id
38+ -- , Gen.Types.Map
39+ -- , Gen.Types.NS
3940
4041 ghc-options: -Wall -threaded
4142
gen/src/Gen/AST.hs+228−227
@@ -10,7 +10,6 @@
1010{-# LANGUAGE RecordWildCards #-}
1111{-# LANGUAGE TemplateHaskell #-}
1212{-# LANGUAGE TupleSections #-}
13−{-# LANGUAGE ViewPatterns #-}
1413
1514-- Module : Gen.AST
1615-- Copyright : (c) 2015 Brendan Hay
@@ -36,235 +35,237 @@ import qualified Data.Text.Lazy.Builder as Build
3635import Debug.Trace
3736import Gen.Formatting
3837import Gen.Solve
39−import Gen.Syntax
38+-- import Gen.Syntax
39+import Gen.AST.Flatten
4040import Gen.Types
4141import HIndent
4242import Language.Haskell.Exts.Build (name)
4343import Language.Haskell.Exts.Pretty
4444import Prelude hiding (sum)
4545
46−runAST :: Parsed -> Either Error Printed
47−runAST svc = evalState (runExceptT go) initial
48− where
49− go = do
50− x <- flatten svc
51− reserve x
52− solveAll x >>= render
53−
54−render :: Typed -> AST Printed
55−render svc = do
56− x <- traverse typ (_svcSchemas svc)
57− y <- api (_svcApi svc)
58−
59− let as = map actionTypeName (Map.elems (_apiActions y))
60− f d = elem (dataName d) as
61− z = trace (show as) $ filter (not . f) (catMaybes x)
62−
63− return $! svc { _svcSchemas = z, _svcParameters = (), _svcApi = y }
64− where
65− typ :: Solved -> AST (Maybe Data)
66− typ Solved{..} = case _schema of
67− Arr {} -> pure Nothing
68− Ref {} -> pure Nothing
69− Any {} -> pure Nothing
70− Lit {} -> pure Nothing
71− Enum i vs ds -> pure . Just $
72− Sum (dname _ident) (i ^. description) $
73− zipWith branch vs (ds ++ repeat mempty)
74− where
75− branch v = Branch (bname _prefix v) v
76−
77− Obj i rs -> fmap Just $
78− prod _ident _prefix i _deriving
79− =<< traverse solve rs
80−
81− prod :: Id -> Pre -> Info -> [Derive] -> Map Local Solved -> AST Data
82− prod k p i ds ts = Prod (dname k) (i ^. description)
83− <$> pp Indent (objDecl k p ds ts)
84− <*> ctor
85− <*> traverse lens (Map.toList ts)
86− <*> traverse (pp Print) (jsonDecls k p ts)
87− where
88− ctor = Fun' (cname k) (Just help)
89− <$> (pp None (ctorSig k ts) <&> comments ts)
90− <*> pp Indent (ctorDecl k p ts)
91−
92− lens (l, v) = Fun' (lname p l) (v ^. description)
93− <$> pp None (lensSig k p l v)
94− <*> pp Print (lensDecl p l v)
95−
96− help = rawHelpText $
97− sformat ("Creates a value of '" % fid %
98− "' with the minimum fields required to make a request.\n")
99− k
100−
101− api :: Resource Solved -> AST API
102− api x = do
103− as <- Map.fromList <$> top x
104− API n <$> pp Print (apiAlias n (Map.keys as))
105− <*> pure as
106− <*> url
107− where
108− n = name (Text.unpack (svcAbbrev svc))
109− un = name (Text.unpack (svcURL svc))
110−
111− url = Fun' un (Just (rawHelpText h))
112− <$> pp None (urlSig un)
113− <*> pp Print url
114− where
115− url | "http://" `Text.isPrefixOf` u = urlDecl un "Http" u 80
116− | otherwise = urlDecl un "Https" u 443
117−
118− u = _svcBaseUrl svc
119−
120− h = sformat ("URL referring to version @" % stext %
121− "@ of the " % stext % ".")
122− (_svcVersion svc) (_svcTitle svc)
123−
124− top = \case
125− Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
126− Sub ms -> traverse (uncurry verb) (Map.toList ms)
127−
128− sub l = \case
129− Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
130− Sub ms -> traverse (uncurry verb) (Map.toList ms)
131−
132− verb l m = do
133− let (k, i, ns) = vname (svcAbbrev svc) (_mId m)
134− s <- solve i
135− Just d <- typ s
136− fmap (k,) $
137− Action k (_mId m) (actionNS ns) (_mDescription m)
138− <$> pp Print (verbAlias k m)
139− <*> reset k m s d
140−
141− reset k m s = \case
142− d@Sum {} -> pure d
143− Prod n' h r c ls _ ->
144− Prod n' h r c ls . (:[]) <$> pp Print
145− (requestDecl (_ident s) (_prefix s) k un (fields (_schema s)) m)
146−
147− fields = \case
148− Obj _ rs -> Map.keys rs
149− _ -> mempty
150−
151−solveAll :: Flattened -> AST Typed
152−solveAll svc = do
153− ss <- traverse solve (_svcSchemas svc)
154− ps <- traverse (traverse solve) (_svcParameters svc)
155− a <- traverse solve (_svcApi svc)
156− pure $! svc { _svcSchemas = ss, _svcParameters = ps, _svcApi = a }
157−
158−flatten :: Parsed -> AST Flattened
159−flatten svc = do
160− _ <- Map.traverseWithKey typ (_svcSchemas svc)
161− ps <- Map.traverseWithKey (prm "") (_svcParameters svc)
162− a <- api ps (_svcApi svc)
163− ss <- uses schemas Map.keys
164− pure $! svc { _svcSchemas = ss, _svcParameters = Map.elems ps, _svcApi = a }
165− where
166− typ :: Id -> Fix Schema -> AST Id
167− typ n (Fix f) = go f >>= ins n
168− where
169− go = \case
170− Obj i ps -> Obj i <$> Map.traverseWithKey (prop n) ps
171− Arr i (Fix e) -> Arr i <$> prop n "item" (Fix (e & required .~ True))
172−
173− Enum i vs ds -> pure (Enum i vs ds)
174− Lit i x -> pure (Lit i x)
175− Ref i r -> pure (Ref i r)
176− Any i -> pure (Any i)
177−
178− prop :: Id -> Local -> Fix Schema -> AST Id
179− prop p l (Fix f) = go f >>= ins this
180− where
181− go = \case
182− Obj i ps -> Obj i <$> Map.traverseWithKey (prop this) ps
183− Arr i (Fix e) -> Arr i <$> prop this "item" (Fix (e & required .~ True))
184−
185− Enum i vs ds -> pure (Enum i vs ds)
186− Lit i x -> pure (Lit i x)
187− Ref i r -> pure (Ref i r)
188− Any i -> pure (Any i)
189−
190− this = mkProp p l
191−
192− prm :: Id -> Local -> Param (Fix Schema) -> AST (Param Id)
193− prm p l x = do
194− n <- prop p l (_prmSchema x)
195− pure $! x { _prmSchema = n }
196−
197− api :: Map Local (Param Id) -> Resource (Fix Schema) -> AST (Resource Id)
198− api qs = \case
199− Top rs -> Top <$> Map.traverseWithKey sub rs
200− Sub ms -> Sub <$> Map.traverseWithKey (verb "") ms
201− where
202− sub l = \case
203− Top rs -> Top <$> Map.traverseWithKey sub rs
204− Sub ms -> Sub <$> Map.traverseWithKey (verb l) ms
205−
206− verb p l m = do
207− let (_, i, _) = vname (svcAbbrev svc) (_mId m)
208− rs <- Map.traverseWithKey (prm i) (_mParameters m)
209− _ <- ins i $
210− Obj (Info (_mDescription m) Nothing False Nothing) (Map.map _prmSchema (rs <> qs))
211− pure $! m { _mParameters = rs <> qs }
212−
213− ins :: Id -> Schema Id -> AST Id
214− ins n x = do
215− ms <- uses schemas (Map.lookup n)
216− case ms of
217− Just y | x /= y -> throwError $
218− format ("Schema exists: " % stext % " - " % fid %
219− "\nCurrent: " % shown % "\nTried: " % shown)
220− (_svcCanonicalName svc) n y x
221− _ -> schemas %= Map.insert n x
222−
223− return n
224−
225−data PP
226− = Indent
227− | Print
228− | None
229− deriving (Eq)
230−
231−pp :: Pretty a => PP -> a -> AST Rendered
232−pp i x
233− | i == Indent = result (reformat johanTibell Nothing p)
234− | otherwise = pure p
235− where
236− result = hoistEither . bimap e Build.toLazyText
237−
238− e = flip mappend (", when formatting: " <> p) . LText.pack
239−
240− p = LText.dropWhile isSpace
241− . LText.pack
242− $ prettyPrintStyleMode s m x
243−
244− s = style
245− { mode = PageMode
246− , lineLength = 80
247− , ribbonsPerLine = 1.5
248− }
249−
250− m | i == Print = defaultMode
251− | i == Indent = defaultMode
252− | otherwise = defaultMode
253− { layout = PPNoLayout
254− , spacing = False
255− }
256−
257−-- FIXME: dirty hack to render smart ctor parameter comments.
258−comments :: Map Local Solved -> Rendered -> Rendered
259−comments (Map.toList -> rs) =
260− LText.replace " :: " "\n :: "
261− . LText.intercalate "\n -> "
262− . zipWith rel ps
263− . map LText.strip
264− . LText.splitOn "->"
265− where
266− ks = filter (parameter . _schema . snd) rs
267− ps = map (Just . fst) ks ++ repeat Nothing
268−
269− rel Nothing t = t
270− rel (Just l) t = t <> " -- ^ '" <> LText.fromStrict (local l) <> "'"
46+-- flatten :: Parsed -> AST Flattened
47+-- flatten svc = do
48+-- _ <- Map.traverseWithKey typ (_svcSchemas svc)
49+-- ps <- Map.traverseWithKey (prm "") (_svcParameters svc)
50+-- a <- api ps (_svcApi svc)
51+-- ss <- uses schemas Map.keys
52+-- pure $! svc { _svcSchemas = ss, _svcParameters = Map.elems ps, _svcApi = a }
53+-- where
54+-- typ :: Id -> Fix Schema -> AST Id
55+-- typ n (Fix f) = go f >>= ins n
56+-- where
57+-- go = \case
58+-- Obj i ps -> Obj i <$> Map.traverseWithKey (prop n) ps
59+-- Arr i (Fix e) -> Arr i <$> prop n "item" (Fix (e & required .~ True))
60+
61+-- Enum i vs ds -> pure (Enum i vs ds)
62+-- Lit i x -> pure (Lit i x)
63+-- Ref i r -> pure (Ref i r)
64+-- Any i -> pure (Any i)
65+
66+-- prop :: Id -> Local -> Fix Schema -> AST Id
67+-- prop p l (Fix f) = go f >>= ins this
68+-- where
69+-- go = \case
70+-- Obj i ps -> Obj i <$> Map.traverseWithKey (prop this) ps
71+-- Arr i (Fix e) -> Arr i <$> prop this "item" (Fix (e & required .~ True))
72+
73+-- Enum i vs ds -> pure (Enum i vs ds)
74+-- Lit i x -> pure (Lit i x)
75+-- Ref i r -> pure (Ref i r)
76+-- Any i -> pure (Any i)
77+
78+-- this = mkProp p l
79+
80+-- prm :: Id -> Local -> Param (Fix Schema) -> AST (Param Id)
81+-- prm p l x = do
82+-- n <- prop p l (_prmSchema x)
83+-- pure $! x { _prmSchema = n }
84+
85+-- api :: Map Local (Param Id) -> Resource (Fix Schema) -> AST (Resource Id)
86+-- api qs = \case
87+-- Top rs -> Top <$> Map.traverseWithKey sub rs
88+-- Sub ms -> Sub <$> Map.traverseWithKey (verb "") ms
89+-- where
90+-- sub l = \case
91+-- Top rs -> Top <$> Map.traverseWithKey sub rs
92+-- Sub ms -> Sub <$> Map.traverseWithKey (verb l) ms
93+
94+-- verb p l m = do
95+-- let (_, i, _) = vname (svcAbbrev svc) (_mId m)
96+-- rs <- Map.traverseWithKey (prm i) (_mParameters m)
97+-- _ <- ins i $
98+-- Obj (Info (_mDescription m) Nothing False Nothing) (Map.map _prmSchema (rs <> qs))
99+-- pure $! m { _mParameters = rs <> qs }
100+
101+-- ins :: Id -> Schema Id -> AST Id
102+-- ins n x = do
103+-- ms <- uses schemas (Map.lookup n)
104+-- case ms of
105+-- Just y | x /= y -> throwError $
106+-- format ("Schema exists: " % stext % " - " % fid %
107+-- "\nCurrent: " % shown % "\nTried: " % shown)
108+-- (_svcCanonicalName svc) n y x
109+-- _ -> schemas %= Map.insert n x
110+
111+-- return n
112+
113+
114+-- runAST :: Parsed -> Either Error Printed
115+-- runAST svc = evalState (runExceptT go) initial
116+-- where
117+-- go = do
118+-- x <- flatten svc
119+-- reserve x
120+-- solveAll x >>= render
121+
122+-- render :: Typed -> AST Printed
123+-- render svc = do
124+-- x <- traverse typ (_svcSchemas svc)
125+-- y <- api (_svcApi svc)
126+
127+-- let as = map actionTypeName (Map.elems (_apiActions y))
128+-- f d = elem (dataName d) as
129+-- z = trace (show as) $ filter (not . f) (catMaybes x)
130+
131+-- return $! svc { _svcSchemas = z, _svcParameters = (), _svcApi = y }
132+-- where
133+-- typ :: Solved -> AST (Maybe Data)
134+-- typ Solved{..} = case _schema of
135+-- Arr {} -> pure Nothing
136+-- Ref {} -> pure Nothing
137+-- Any {} -> pure Nothing
138+-- Lit {} -> pure Nothing
139+-- Enum i vs ds -> pure . Just $
140+-- Sum (dname _ident) (i ^. description) $
141+-- zipWith branch vs (ds ++ repeat mempty)
142+-- where
143+-- branch v = Branch (bname _prefix v) v
144+
145+-- Obj i rs -> fmap Just $
146+-- prod _ident _prefix i _deriving
147+-- =<< traverse solve rs
148+
149+-- prod :: Id -> Pre -> Info -> [Derive] -> Map Local Solved -> AST Data
150+-- prod k p i ds ts = Prod (dname k) (i ^. description)
151+-- <$> pp Indent (objDecl k p ds ts)
152+-- <*> ctor
153+-- <*> traverse lens (Map.toList ts)
154+-- <*> traverse (pp Print) (jsonDecls k p ts)
155+-- where
156+-- ctor = Fun' (cname k) (Just help)
157+-- <$> (pp None (ctorSig k ts) <&> comments ts)
158+-- <*> pp Indent (ctorDecl k p ts)
159+
160+-- lens (l, v) = Fun' (lname p l) (v ^. description)
161+-- <$> pp None (lensSig k p l v)
162+-- <*> pp Print (lensDecl p l v)
163+
164+-- help = rawHelpText $
165+-- sformat ("Creates a value of '" % fid %
166+-- "' with the minimum fields required to make a request.\n")
167+-- k
168+
169+-- api :: Resource Solved -> AST API
170+-- api x = do
171+-- as <- Map.fromList <$> top x
172+-- API n <$> pp Print (apiAlias n (Map.keys as))
173+-- <*> pure as
174+-- <*> url
175+-- where
176+-- n = name (Text.unpack (svcAbbrev svc))
177+-- un = name (Text.unpack (svcURL svc))
178+
179+-- url = Fun' un (Just (rawHelpText h))
180+-- <$> pp None (urlSig un)
181+-- <*> pp Print url
182+-- where
183+-- url | "http://" `Text.isPrefixOf` u = urlDecl un "Http" u 80
184+-- | otherwise = urlDecl un "Https" u 443
185+
186+-- u = _svcBaseUrl svc
187+
188+-- h = sformat ("URL referring to version @" % stext %
189+-- "@ of the " % stext % ".")
190+-- (_svcVersion svc) (_svcTitle svc)
191+
192+-- top = \case
193+-- Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
194+-- Sub ms -> traverse (uncurry verb) (Map.toList ms)
195+
196+-- sub l = \case
197+-- Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
198+-- Sub ms -> traverse (uncurry verb) (Map.toList ms)
199+
200+-- verb l m = do
201+-- let (k, i, ns) = vname (svcAbbrev svc) (_mId m)
202+-- s <- solve i
203+-- Just d <- typ s
204+-- fmap (k,) $
205+-- Action k (_mId m) (actionNS ns) (_mDescription m)
206+-- <$> pp Print (verbAlias k m)
207+-- <*> reset k m s d
208+
209+-- reset k m s = \case
210+-- d@Sum {} -> pure d
211+-- Prod n' h r c ls _ ->
212+-- Prod n' h r c ls . (:[]) <$> pp Print
213+-- (requestDecl (_ident s) (_prefix s) k un (fields (_schema s)) m)
214+
215+-- fields = \case
216+-- Obj _ rs -> Map.keys rs
217+-- _ -> mempty
218+
219+-- solveAll :: Flattened -> AST Typed
220+-- solveAll svc = do
221+-- ss <- traverse solve (_svcSchemas svc)
222+-- ps <- traverse (traverse solve) (_svcParameters svc)
223+-- a <- traverse solve (_svcApi svc)
224+-- pure $! svc { _svcSchemas = ss, _svcParameters = ps, _svcApi = a }
225+
226+-- data PP
227+-- = Indent
228+-- | Print
229+-- | None
230+-- deriving (Eq)
231+
232+-- pp :: Pretty a => PP -> a -> AST Rendered
233+-- pp i x
234+-- | i == Indent = result (reformat johanTibell Nothing p)
235+-- | otherwise = pure p
236+-- where
237+-- result = hoistEither . bimap e Build.toLazyText
238+
239+-- e = flip mappend (", when formatting: " <> p) . LText.pack
240+
241+-- p = LText.dropWhile isSpace
242+-- . LText.pack
243+-- $ prettyPrintStyleMode s m x
244+
245+-- s = style
246+-- { mode = PageMode
247+-- , lineLength = 80
248+-- , ribbonsPerLine = 1.5
249+-- }
250+
251+-- m | i == Print = defaultMode
252+-- | i == Indent = defaultMode
253+-- | otherwise = defaultMode
254+-- { layout = PPNoLayout
255+-- , spacing = False
256+-- }
257+
258+-- -- FIXME: dirty hack to render smart ctor parameter comments.
259+-- comments :: Map Local Solved -> Rendered -> Rendered
260+-- comments (Map.toList -> rs) =
261+-- LText.replace " :: " "\n :: "
262+-- . LText.intercalate "\n -> "
263+-- . zipWith rel ps
264+-- . map LText.strip
265+-- . LText.splitOn "->"
266+-- where
267+-- ks = filter (parameter . _schema . snd) rs
268+-- ps = map (Just . fst) ks ++ repeat Nothing
269+
270+-- rel Nothing t = t
271+-- rel (Just l) t = t <> " -- ^ '" <> LText.fromStrict (local l) <> "'"
gen/src/Gen/AST/Flatten.hsnew file+156
@@ -0,0 +1,156 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE RecordWildCards #-}
11+{-# LANGUAGE TemplateHaskell #-}
12+{-# LANGUAGE TupleSections #-}
13+
14+-- Module : Gen.AST.Flatten
15+-- Copyright : (c) 2015 Brendan Hay
16+-- License : Mozilla Public License, v. 2.0.
17+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
18+-- Stability : provisional
19+-- Portability : non-portable (GHC extensions)
20+
21+module Gen.AST.Flatten
22+ ( flatten
23+ ) where
24+
25+import Control.Applicative
26+import Control.Error
27+import Control.Lens hiding (lens)
28+import Control.Monad.Except
29+import Control.Monad.State.Strict
30+import Data.Char
31+import qualified Data.HashMap.Strict as Map
32+import Data.Maybe
33+import Data.Semigroup ((<>))
34+import qualified Data.Text as Text
35+import qualified Data.Text.Lazy as LText
36+import qualified Data.Text.Lazy.Builder as Build
37+import Debug.Trace
38+import Gen.Formatting
39+-- import Gen.Solve
40+-- import Gen.Syntax
41+import Gen.Types
42+import HIndent
43+import Language.Haskell.Exts.Build (name)
44+import Language.Haskell.Exts.Pretty
45+import Prelude hiding (sum)
46+
47+flatten :: Service (Fix Schema) -> AST (Service Global)
48+flatten s = do
49+ _ <- Map.traverseWithKey globalSchema (s ^. dSchemas)
50+ ps <- Map.traverseWithKey globalParam (s ^. dParameters)
51+ rs <- Map.traverseWithKey globalResource (s ^. dResources)
52+ ms <- traverse method (s ^. dMethods)
53+
54+ ss <- use schemas
55+
56+ let d = (s ^. sDescription)
57+ { _dSchemas = ss
58+ , _dParameters = ps
59+ , _dMethods = ms
60+ , _dResources = rs
61+ }
62+
63+ pure $! s { _sDescription = d }
64+
65+globalSchema :: Global -> Schema (Fix Schema) -> AST Global
66+globalSchema g = schema g Nothing
67+
68+localSchema :: Global -> Local -> Fix Schema -> AST Global
69+localSchema g l (Fix s) = schema g (Just l) s
70+
71+schema :: Global -> Maybe Local -> Schema (Fix Schema) -> AST Global
72+schema g ml = go >=> insert this
73+ where
74+ this :: Global
75+ this = maybe g (reference g) ml
76+
77+ go :: Schema (Fix Schema) -> AST (Schema Global)
78+ go = \case
79+ SRef i r -> pure (SRef i r)
80+ SLit i l -> pure (SLit i l)
81+ SEnm i e -> pure (SEnm i e)
82+ SArr i a -> SArr i <$> array a
83+ SObj i o -> SObj i <$> object o
84+
85+ array (Arr e) =
86+ Arr <$> localSchema this "item" (setRequired e)
87+
88+ object (Obj ap ps) =
89+ Obj Nothing <$> Map.traverseWithKey (localSchema this) ps
90+
91+setRequired :: Fix Schema -> Fix Schema
92+setRequired (Fix e) = Fix (e & iRequired .~ True)
93+
94+insert :: Global -> Schema Global -> AST Global
95+insert g s = do
96+ ms <- uses schemas (Map.lookup g)
97+ n <- use sCanonicalName
98+ case ms of
99+ Just s' | s /= s' -> throwError (exists n s')
100+ _ -> pure ()
101+ schemas %= Map.insert g s
102+ pure g
103+ where
104+ exists n x =
105+ format ("Schema exists: " % stext % " - " % gid %
106+ "\nCurrent: " % shown % "\nTried: " % shown)
107+ n g x s
108+
109+globalParam :: Local -> Param (Fix Schema) -> AST (Param Global)
110+globalParam = localParam "param"
111+
112+localParam :: Global -> Local -> Param (Fix Schema) -> AST (Param Global)
113+localParam g l p = do
114+ x <- localSchema g l (_pParam p)
115+ pure $! p { _pParam = x }
116+
117+globalResource :: Global
118+ -> Resource Global (Fix Schema)
119+ -> AST (Resource Global Global)
120+globalResource = undefined
121+
122+localResource :: Global
123+ -> Resource Local (Fix Schema)
124+ -> AST (Resource Local Global)
125+localResource = undefined
126+
127+method :: Method (Fix Schema) -> AST (Method Global)
128+method = undefined
129+
130+-- api :: Map Local (Param Id) -> Resource (Fix Schema) -> AST (Resource Id)
131+-- api qs = \case
132+-- Top rs -> Top <$> Map.traverseWithKey sub rs
133+-- Sub ms -> Sub <$> Map.traverseWithKey (verb "") ms
134+-- where
135+-- sub l = \case
136+-- Top rs -> Top <$> Map.traverseWithKey sub rs
137+-- Sub ms -> Sub <$> Map.traverseWithKey (verb l) ms
138+
139+-- verb p l m = do
140+-- let (_, i, _) = vname (svcAbbrev svc) (_mId m)
141+-- rs <- Map.traverseWithKey (prm i) (_mParameters m)
142+-- _ <- ins i $
143+-- Obj (Info (_mDescription m) Nothing False Nothing) (Map.map _prmSchema (rs <> qs))
144+-- pure $! m { _mParameters = rs <> qs }
145+
146+-- ins :: Id -> Schema Id -> AST Id
147+-- ins n x = do
148+-- ms <- uses schemas (Map.lookup n)
149+-- case ms of
150+-- Just y | x /= y -> throwError $
151+-- format ("Schema exists: " % stext % " - " % fid %
152+-- "\nCurrent: " % shown % "\nTried: " % shown)
153+-- (_svcCanonicalName svc) n y x
154+-- _ -> schemas %= Map.insert n x
155+
156+-- return n
gen/src/Gen/Names.hsnew file+9
@@ -0,0 +1,9 @@
1+-- Module : Gen.Names
2+-- Copyright : (c) 2015 Brendan Hay
3+-- License : Mozilla Public License, v. 2.0.
4+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
5+-- Stability : provisional
6+-- Portability : non-portable (GHC extensions)
7+
8+module Gen.Names where
9+
gen/src/Gen/Orphans.hs+1
@@ -12,6 +12,7 @@
1212module Gen.Orphans where
1313
1414import Data.Aeson
15+import Data.Aeson.Types
1516import Data.Bifunctor
1617import Data.Hashable
1718import qualified Data.HashMap.Strict as Map
gen/src/Gen/Schema.hsdeleted−336
@@ -1,336 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−{-# LANGUAGE LambdaCase #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−module Gen.Schema where
6−
7−import Control.Applicative
8−import Control.Lens hiding ((.=))
9−import Data.Aeson hiding (Array, Bool, Object,
10− String)
11−import qualified Data.Aeson as A
12−import Data.Aeson.TH
13−import Data.Char
14−import Data.Function (on)
15−import qualified Data.HashMap.Strict as Map
16−import qualified Data.HashSet as Set
17−import Data.List (groupBy, sort, sortOn)
18−import Data.List.NonEmpty (NonEmpty (..))
19−import qualified Data.List.NonEmpty as NE
20−import Data.Maybe
21−import Data.Ord
22−import Data.Semigroup ((<>))
23−import Data.Text (Text)
24−import qualified Data.Text as Text
25−import qualified Data.Text.Lazy as LText
26−import qualified Data.Text.Lazy.Builder as Build
27−import Data.Text.Manipulate
28−import qualified Data.Text.Read as Read
29−import qualified Filesystem.Path.CurrentOS as Path
30−import Formatting
31−import Gen.Orphans ()
32−import Gen.Text
33−import Gen.Types.Help
34−import Gen.Types.Id
35−import Gen.Types.Map
36−import Gen.Types.NS
37−import GHC.Generics
38−import GHC.TypeLits
39−import Language.Haskell.Exts (Name)
40−import Language.Haskell.Exts.Pretty (Pretty, prettyPrint)
41−import Prelude hiding (Enum)
42−import Text.EDE (Template)
43−
44−newtype Fix f = Fix (f (Fix f))
45−
46−type Set = Set.HashSet
47−type Error = LText.Text
48−type Rendered = LText.Text
49−type Path = Path.FilePath
50−
51−data Location
52− = Query
53− | Path
54− deriving (Eq, Show)
55−
56−deriveJSON options ''Location
57−
58−newtype Ann = Ann { annRequired :: [Text] }
59− deriving (Eq, Show, Monoid)
60−
61−deriveJSON options ''Ann
62−
63−data Info = Info
64− { _iId :: Maybe Text
65− , _iDescription :: Maybe Help
66− , _iDefault :: Maybe Text
67− , _iRequired :: Bool
68− , _iPattern :: Maybe Text
69− , _iMinimum :: Maybe Text
70− , _iMaximum :: Maybe Text
71− , _iRepeated :: Bool
72− , _iAnnotations :: Ann
73− } deriving (Eq, Show)
74−
75−makeClassy ''Info
76−
77−instance FromJSON Info where
78− parseJSON = withObject "info" $ \o -> Info
79− <$> o .: "id"
80− <*> o .:? "description"
81− <*> o .:? "default"
82− <*> o .:? "required" .!= False
83− <*> o .:? "pattern"
84− <*> o .:? "minimum"
85− <*> o .:? "maximum"
86− <*> o .:? "repeated" .!= False
87− <*> o .:? "annotations" .!= mempty
88−
89−data Schema
90− = SRef Info Ref
91− | SLit Info Literal
92− | SEnum Info Enum
93− | SArr Info Array
94− | SObj Info Object
95− deriving (Eq, Show)
96−
97−instance FromJSON Schema where
98− parseJSON o = do
99− i <- parseJSON o
100− SRef i <$> parseJSON o
101− <|> SLit i <$> parseJSON o
102− <|> SEnum i <$> parseJSON o
103− <|> SArr i <$> parseJSON o
104− <|> SObj i <$> parseJSON o
105−
106−instance HasInfo Schema where
107− info = lens f (flip g)
108− where
109− f = \case
110− SRef i _ -> i
111− SLit i _ -> i
112− SEnum i _ -> i
113− SArr i _ -> i
114− SObj i _ -> i
115−
116− g i = \case
117− SRef _ x -> SRef i x
118− SLit _ x -> SLit i x
119− SEnum _ x -> SEnum i x
120− SArr _ x -> SArr i x
121− SObj _ x -> SObj i x
122−
123−newtype Ref = Ref { ref :: Text }
124− deriving (Eq, Show)
125−
126−instance FromJSON Ref where
127− parseJSON = withObject "ref" (fmap Ref . (.: "$ref"))
128−
129−data Literal
130− = Text
131− | Bool
132− | Float
133− | Double
134− | Byte
135− | UInt32
136− | UInt64
137− | Int32
138− | Int64
139− | Date
140− | Time
141− deriving (Eq, Show)
142−
143−instance FromJSON Literal where
144− parseJSON = withObject "literal" $ \o -> do
145− t <- o .: "format" <|> o .: "type"
146− case t of
147− -- Types
148− "string" -> pure Text
149− "boolean" -> pure Bool
150−
151− -- Formats
152− "float" -> pure Float
153− "double" -> pure Double
154− "byte" -> pure Byte
155− "uint32" -> pure UInt32
156− "uint64" -> pure UInt64
157− "int32" -> pure Int32
158− "int64" -> pure Int64
159− "date" -> pure Date
160− "date-time" -> pure Time
161−
162− _ -> fail $
163− "Unable to parse Literal from: " ++ Text.unpack t
164−
165−newtype Enum = Enum { _eValues :: [(Text, Help)] }
166− deriving (Eq, Show)
167−
168−instance FromJSON Enum where
169− parseJSON = withObject "enum" $ \o -> do
170− vs <- o .: "enum"
171− ds <- o .: "enumDescriptions"
172− pure $! Enum (zip vs (ds ++ repeat mempty))
173−
174−newtype Array = Array { _aItem :: Schema }
175− deriving (Eq, Show)
176−
177−instance FromJSON Array where
178− parseJSON = withObject "array" (fmap Array . (.: "item"))
179−
180−data Object = Object
181− { _oProperties :: Map Text Schema
182− , _oAdditionalProperties :: Maybe Schema
183− } deriving (Eq, Show)
184−
185−deriveFromJSON options ''Object
186−
187−data Param = Param
188− { _pLocation :: Location
189− , _pSchema :: Schema
190− } deriving (Eq, Show)
191−
192−makeLenses ''Param
193−
194−instance FromJSON Param where
195− parseJSON = withObject "param" $ \o -> Param
196− <$> o .: "location"
197− <*> parseJSON (A.Object o)
198−
199−instance HasInfo Param where
200− info = pSchema . info
201−
202−data MediaUpload = MediaUpload
203− { _muAccept :: [Text]
204− , _muMaxSize :: Text
205− , _muResumablePath :: Text
206− , _muSimplePath :: Text
207− } deriving (Eq, Show)
208−
209−instance FromJSON MediaUpload where
210− parseJSON = withObject "mediaUpload" $ \o -> MediaUpload
211− <$> o .: "accept"
212− <*> o .: "maxSize"
213− <*> (o .: "protocols" >>= (.: "resumable") >>= (.: "path"))
214− <*> (o .: "protocols" >>= (.: "simple") >>= (.: "path"))
215−
216−data Method = Method
217− { _mId :: Text
218− , _mPath :: Text
219− , _mHttpMethod :: Text
220− , _mDescription :: Help
221− , _mParameters :: Map Text Param
222− , _mParameterOrder :: [Text]
223− , _mRequest :: Maybe Ref
224− , _mResponse :: Maybe Ref
225− , _mScopes :: [Text]
226− , _mSupportsMediaUpload :: Bool
227− , _mSupportsMediaDownload :: Bool
228− , _mMediaUpload :: Maybe MediaUpload
229− , _mSupportsSubscription :: Bool
230− } deriving (Eq, Show)
231−
232−instance FromJSON Method where
233− parseJSON = withObject "method" $ \o -> Method
234− <$> o .: "id"
235− <*> o .: "path"
236− <*> o .: "httpMethod"
237− <*> o .: "description"
238− <*> o .:? "parameters" .!= mempty
239− <*> o .:? "parameterOrder" .!= mempty
240− <*> o .:? "request"
241− <*> o .:? "response"
242− <*> o .:? "scopes" .!= mempty
243− <*> o .:? "supportsMediaUpload" .!= False
244− <*> o .:? "supportsMediaDownload" .!= False
245− <*> o .:? "mediaUpload"
246− <*> o .:? "supportsSubscription" .!= False
247−
248−data Resource = Resource
249− { _rMethods :: Map Text Method
250− , _rResources :: Map Text Resource
251− } deriving (Eq, Show)
252−
253−instance FromJSON Resource where
254− parseJSON = withObject "resource" $ \o -> Resource
255− <$> o .:? "methods" .!= mempty
256− <*> o .:? "resources" .!= mempty
257−
258−newtype OAuth2 = OAuth2 { scopes :: Map Text Text }
259− deriving (Eq, Show)
260−
261−instance FromJSON OAuth2 where
262− parseJSON = withObject "oauth2" $ \o ->
263− o .: "oauth2" >>=
264− withObject "scopes" (.: "scopes")
265−
266−data Description = Description
267− { _dKind :: Text
268− , _dDiscoveryVersion :: Text
269− , _dId :: Text
270− , _dName :: Text
271− , _dVersion :: Text
272− , _dRevision :: Text
273− , _dTitle :: Text
274− , _dDescription :: Help
275− , _dIcons :: Map Text Text
276− , _dDocumentationLink :: Text
277− , _dLabels :: Text
278− , _dProtocol :: Text
279− , _dBaseUrl :: Text
280− , _dRootUrl :: Text
281− , _dServicePath :: Text
282− , _dBatchPath :: Text
283− , _dParameters :: Map Text Param
284− , _dAuth :: OAuth2
285− , _dFeatures :: [Text]
286− , _dSchemas :: Map Text Schema
287− , _dMethods :: Map Text Method
288− , _dResources :: Map Text Resource
289− } deriving (Eq, Show)
290−
291−makeClassy ''Description
292−
293−instance FromJSON Description where
294− parseJSON = withObject "description" $ \o -> Description
295− <$> o .: "kind"
296− <*> o .: "discoveryVersion"
297− <*> o .: "id"
298− <*> o .: "name"
299− <*> o .: "version"
300− <*> o .: "revision"
301− <*> o .: "title"
302− <*> o .: "description"
303− <*> o .: "icons"
304− <*> o .: "documentationLink"
305− <*> o .: "labels"
306− <*> o .: "protocol"
307− <*> o .: "baseUrl"
308− <*> o .: "rootUrl"
309− <*> o .: "servicePath"
310− <*> o .: "batchPath"
311− <*> o .:? "parameters" .!= mempty
312− <*> o .: "auth"
313− <*> o .:? "features" .!= mempty
314− <*> o .:? "schemas" .!= mempty
315− <*> o .:? "methods" .!= mempty
316− <*> o .:? "resources" .!= mempty
317−
318−data Service = Service
319− { _sLibrary :: Text
320− , _sCanonicalName :: Text
321− , _sOwnerName :: Text
322− , _sOwnerDomain :: Text
323− , _sPackagePath :: Maybe Text
324− , _sDescription :: Description
325− } deriving (Eq, Show)
326−
327−makeLenses ''Service
328−
329−instance FromJSON Service where
330− parseJSON = withObject "service" $ \o -> Service
331− <$> o .: "library"
332− <*> o .: "canonicalName"
333− <*> o .: "ownerName"
334− <*> o .: "ownerDomain"
335− <*> o .: "packagePath"
336− <*> parseJSON (A.Object o)
gen/src/Gen/Solve.hs+4−22
@@ -42,28 +42,10 @@ import Gen.Text
4242import Gen.Types
4343import Prelude hiding (sum)
4444
45−type Seen = Map (CI Text) (Set (CI Text))
46−
47−data Memo = Memo
48− { _typed :: Map Id TType
49− , _derived :: Map Id [Derive]
50− , _prefixed :: Map Id Pre
51− , _branches :: Seen
52− , _fields :: Seen
53− , _schemas :: Map Id (Schema Id)
54− }
55−
56−initial :: Memo
57−initial = Memo mempty mempty mempty mempty mempty mempty
58−
59−makeLenses ''Memo
60−
61−type AST = ExceptT Error (State Memo)
62−
63−reserve :: Flattened -> AST ()
64−reserve svc = do
65− let bs = Set.fromList $ map (CI.mk . idToText) (_svcSchemas svc)
66− branches %= Map.insert mempty bs
45+-- reserve :: Flattened -> AST ()
46+-- reserve svc = do
47+-- let bs = Set.fromList $ map (CI.mk . idToText) (_svcSchemas svc)
48+-- branches %= Map.insert mempty bs
6749
6850schema :: Id -> AST (Schema Id)
6951schema k = do
gen/src/Gen/TH.hsnew file+27
@@ -0,0 +1,27 @@
1+-- Module : Gen.TH
2+-- Copyright : (c) 2015 Brendan Hay
3+-- License : Mozilla Public License, v. 2.0.
4+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
5+-- Stability : provisional
6+-- Portability : non-portable (GHC extensions)
7+
8+module Gen.TH where
9+
10+import Data.Aeson.Types
11+import Data.Char
12+
13+options :: Options
14+options = defaultOptions
15+ { constructorTagModifier = map toLower
16+ , fieldLabelModifier = \s ->
17+ let x:xs = dropWhile (not . isUpper) s in toLower x : xs
18+ }
19+
20+-- -- Wut?
21+-- js :: String -> Options
22+-- js pre = defaultOptions
23+-- { constructorTagModifier = map toLower
24+-- , fieldLabelModifier = \s ->
25+-- let x:xs = drop (length pre) s
26+-- in toLower x : xs
27+-- }
gen/src/Gen/Types.hs+130−441
@@ -6,15 +6,16 @@
66{-# LANGUAGE ExtendedDefaultRules #-}
77{-# LANGUAGE FlexibleContexts #-}
88{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE FunctionalDependencies #-}
910{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1011{-# LANGUAGE KindSignatures #-}
1112{-# LANGUAGE LambdaCase #-}
13+{-# LANGUAGE MultiParamTypeClasses #-}
1214{-# LANGUAGE OverloadedStrings #-}
15+{-# LANGUAGE RankNTypes #-}
1316{-# LANGUAGE RecordWildCards #-}
1417{-# LANGUAGE TemplateHaskell #-}
1518
16−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
17−
1819-- Module : Gen.Types
1920-- Copyright : (c) 2015 Brendan Hay
2021-- License : Mozilla Public License, v. 2.0.
@@ -28,12 +29,19 @@ module Gen.Types
2829 , module Gen.Types.Id
2930 , module Gen.Types.Map
3031 , module Gen.Types.NS
32+ , module Gen.Types.Schema
33+ , module Gen.Types.Data
3134 ) where
3235
3336import Control.Applicative
3437import Control.Lens hiding ((.=))
35−import Data.Aeson hiding (Bool, String)
38+import Control.Monad.Except
39+import Control.Monad.State.Strict
40+import Data.Aeson hiding (Array, Bool, String)
41+import qualified Data.Aeson as A
3642import Data.Aeson.TH
43+import Data.CaseInsensitive (CI)
44+import qualified Data.CaseInsensitive as CI
3745import Data.Char
3846import Data.Function (on)
3947import qualified Data.HashMap.Strict as Map
@@ -54,37 +62,23 @@ import qualified Filesystem.Path.CurrentOS as Path
5462import Formatting
5563import Gen.Orphans ()
5664import Gen.Text
65+import Gen.TH
66+import Gen.Types.Data
5767import Gen.Types.Help
5868import Gen.Types.Id
5969import Gen.Types.Map
6070import Gen.Types.NS
71+import Gen.Types.Schema
6172import GHC.Generics
6273import GHC.TypeLits
6374import Language.Haskell.Exts (Name)
6475import Language.Haskell.Exts.Pretty (Pretty, prettyPrint)
76+import Prelude hiding (Enum)
6577import Text.EDE (Template)
6678
67−default (Text)
68−
69−newtype Fix f = Fix (f (Fix f))
70−
71−type Set = Set.HashSet
72−type Error = LText.Text
73−type Rendered = LText.Text
74−type Path = Path.FilePath
75−
76−toTextIgnore :: Path -> Text
77−toTextIgnore = either id id . Path.toText
78−
79−data Templates = Templates
80− { cabalTemplate :: Template
81− , tocTemplate :: Template
82− , readmeTemplate :: Template
83− , typesTemplate :: Template
84− , prodTemplate :: Template
85− , sumTemplate :: Template
86− , actionTemplate :: Template
87− }
79+type Set = Set.HashSet
80+type Error = LText.Text
81+type Path = Path.FilePath
8882
8983newtype Version (v :: Symbol) = Version Text
9084 deriving (Eq, Show)
@@ -105,193 +99,118 @@ data Versions = Versions
10599 , _coreVersion :: CoreVer
106100 } deriving (Show)
107101
108−-- FIXME: need a more comprehensive 'vm_alpha' vs 'vm1.1' etc check.
109−data Spec = Spec
110− { _specName :: Text
111− , _specPrefix :: Text
112− , _specVersion :: Text
113− , _specPath :: Path
102+makeClassy ''Versions
103+
104+-- FIXME: need a more comprehensive 'vm_alpha' vs 'vm1.1' version check.
105+data Model = Model
106+ { modelName :: Text
107+ , modelPrefix :: Text
108+ , modelVersion :: Text
109+ , modelPath :: Path
114110 }
115111
116−instance Eq Spec where
117− (==) = on (==) _specPrefix
112+instance Eq Model where
113+ (==) = on (==) modelPrefix
118114
119−instance Ord Spec where
115+instance Ord Model where
120116 compare a b =
121− on compare _specPrefix a b
122− <> on compare (Down . _specVersion) a b
117+ on compare modelPrefix a b
118+ <> on compare (Down . modelVersion) a b
123119
124−specFromPath :: Path -> Spec
125−specFromPath x = Spec n p v x
120+modelFromPath :: Path -> Model
121+modelFromPath x = Model n p v x
126122 where
127− -- FIXME:
128− n = Text.init
129− . Text.intercalate "/"
130− . drop 1
131− . dropWhile (/= "model")
132− $ Text.split (== '/') p
123+ n = Text.init
124+ . Text.intercalate "/"
125+ . drop 1
126+ . dropWhile (/= "model")
127+ $ Text.split (== '/') p
133128
134− p = toTextIgnore (Path.parent (Path.parent x))
135− v = toTextIgnore (Path.dirname x)
129+ p = toTextIgnore (Path.parent (Path.parent x))
130+ v = toTextIgnore (Path.dirname x)
136131
137−data Protocol = REST
138− deriving (Eq, Show)
132+data Templates = Templates
133+ { cabalTemplate :: Template
134+ , tocTemplate :: Template
135+ , readmeTemplate :: Template
136+ , typesTemplate :: Template
137+ , prodTemplate :: Template
138+ , sumTemplate :: Template
139+ , actionTemplate :: Template
140+ }
139141
140−instance FromJSON Protocol where
141− parseJSON = withText "protocol" $ \case
142− "rest" -> pure REST
143− e -> fail $ "Unable to parse protocol from " ++ Text.unpack e
142+tocImports, typeImports, prodImports, sumImports, actionImports
143+ :: Service a -> [NS]
144+tocImports _ = [preludeNS]
145+typeImports s = sort [preludeNS, prodNS s, sumNS s]
146+prodImports s = sort [preludeNS, sumNS s]
147+sumImports _ = [preludeNS]
148+actionImports s = sort [preludeNS, typesNS s]
149+
150+tocNS, typesNS, prodNS, sumNS :: Service a -> NS
151+tocNS = mappend "Network.Google" . mkNS . _sCanonicalName
152+typesNS = (<> "Types") . tocNS
153+prodNS = (<> "Product") . typesNS
154+sumNS = (<> "Sum") . typesNS
144155
145−instance ToJSON Protocol where
146− toJSON = toJSON . map toLower . show
156+preludeNS :: NS
157+preludeNS = "Network.Google.Prelude"
147158
148−data Location
149− = Query
150− | Path
151− deriving (Eq, Show)
159+-- actionNS :: [Text] -> NS
160+-- actionNS = mappend (NS ["Network", "Google", "API"]) . NS
152161
153−deriveJSON (js "") ''Location
154−
155−data Info = Info
156− { _description :: Maybe Help
157− , _defaulted :: Maybe Text
158− , _required :: !Bool
159− , _location :: Maybe Location
160− } deriving (Eq, Show)
161−
162−instance FromJSON Info where
163− parseJSON = withObject "info" $ \o -> Info
164− <$> o .:? "description"
165− <*> o .:? "default"
166− <*> o .:? "required" .!= False
167− <*> o .:? "location"
168−
169−deriveToJSON (js "_info") ''Info
170−
171−makeClassy ''Info
172−
173−parameter :: HasInfo a => a -> Bool
174−parameter s = s ^. required && isNothing (s ^. defaulted)
175−
176−data Lit
177− = Text
178− | Bool
179− | Float
180− | Double
181− | Byte
182− | UInt32
183− | UInt64
184− | Int32
185− | Int64
186− | Nat
187− | Date
188− | Time
189− deriving (Eq, Show)
162+-- exposedModules :: Service s p API -> [NS]
163+-- exposedModules s = sort (tocNS s : typesNS s : map _actNS (svcActions s))
190164
191−instance FromJSON Lit where
192− parseJSON = withObject "literal" $ \o -> do
193− n <- num =<< (o .:? "minimum" .!= "0")
194− (o .: "format" <|> o .: "type") >>= \case
195− -- Types
196− "string" -> pure Text
197− "boolean" -> pure Bool
198− -- Formats
199− "float" -> pure Float
200− "double" -> pure Double
201− "byte" -> pure (nat n Byte)
202− "uint32" -> pure (nat n UInt32)
203− "uint64" -> pure (nat n UInt64)
204− "int32" -> pure (nat n Int32)
205− "int64" -> pure (nat n Int64)
206− "date" -> pure Date
207− "date-time" -> pure Time
208− e -> fail $
209− "Unable to parse Lit from " ++ Text.unpack e
210− where
211− num = either fail (pure . fst) . Read.decimal
212−
213− nat :: Int -> Lit -> Lit
214− nat n | n > 0 = const Nat
215− | otherwise = id
216−
217−-- "pattern": "[A-Z]{3}",
218−-- "pattern": "[0-9a-zA-Z,]+",
219−-- "pattern": "[a-zA-Z]+==[a-zA-Z0-9_+-]+",
220−-- "minimum": "1"
221−-- "format": "date-time", "uint64", "int32",
222−
223−deriveToJSON (js "") ''Lit
224−
225−data Schema a
226− = Obj Info (Map Local a)
227− | Arr Info a
228− | Enum Info [Text] [Help]
229− | Lit Info Lit
230− | Ref Info Global
231− | Any Info -- String or Number
232− deriving (Eq, Show, Functor, Foldable, Traversable)
233−
234−instance FromJSON (Fix Schema) where
235− parseJSON = withObject "schema" $ \o -> do
236− i <- parseJSON (Object o)
237− Fix <$> (ref i o <|> schema i o)
238− where
239− schema i o = o .: "type" >>= \case
240− "object" -> Obj i <$> o .:? "properties" .!= mempty
241− "array" -> Arr i <$> o .: "items"
242− "any" -> pure (Any i)
243− _ -> enm i o <|> Lit i <$> parseJSON (Object o)
165+-- otherModules :: Service s p r -> [NS]
166+-- otherModules s = sort [prodNS s, sumNS s]
167+
168+toTextIgnore :: Path -> Text
169+toTextIgnore = either id id . Path.toText
170+
171+data Library = Library
172+ { _lVersions :: Versions
173+ , _lService :: Service Global
174+ -- , _lMethods ::
175+ -- , _lResources :: []
176+ -- , _lSchemas :: [Data]
177+ }
244178
245− enm i o = Enum i <$> o .: "enum" <*> o .: "enumDescriptions"
246− ref i o = Ref i <$> o .: "$ref"
179+makeLenses ''Library
247180
248−deriveToJSON (js "") ''Schema
181+instance HasVersions Library where
182+ versions = lVersions
183+
184+instance HasDescription Library Global where
185+ description = lService . description
186+
187+instance HasService Library Global where
188+ service = lService
189+
190+instance ToJSON Library where
191+ toJSON l = object
192+ [ "libraryName" .= (l ^. sLibrary)
193+ , "libraryTitle" .= (l ^. dTitle)
194+ , "libraryDescription" .= Desc 4 (l ^. dDescription)
195+ , "libraryVersion" .= (l ^. libraryVersion)
196+ , "coreVersion" .= (l ^. coreVersion)
197+ , "clientVersion" .= (l ^. clientVersion)
198+ -- , "exposedModules" .= concatMap exposedModules (NE.toList _libServices)
199+ -- , "otherModules" .= concatMap otherModules (NE.toList _libServices)
200+ ]
201+
202+-- data Service = Service
203+-- { _sLibrary :: Text
204+-- , _sCanonicalName :: Text
205+-- , _sOwnerName :: Text
206+-- , _sOwnerDomain :: Text
207+-- , _sPackagePath :: Maybe Text
208+-- , _sDescription :: Description
209+-- } deriving (Eq, Show)
249210
250−instance HasInfo (Schema a) where
251− info = lens f (flip g)
252− where
253− f = \case
254− Obj i _ -> i
255− Arr i _ -> i
256− Enum i _ _ -> i
257− Lit i _ -> i
258− Ref i _ -> i
259− Any i -> i
260−
261− g i = \case
262− Obj _ p -> Obj i p
263− Arr _ e -> Arr i e
264− Enum _ v d -> Enum i v d
265− Lit _ l -> Lit i l
266− Ref _ r -> Ref i r
267− Any {} -> Any i
268−
269−data Param a = Param
270− { _prmLocation :: !Location
271− , _prmRepeated :: !Bool
272− , _prmInfo :: Info
273− , _prmSchema :: a
274− } deriving (Show, Functor, Foldable, Traversable)
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−
283−instance FromJSON a => FromJSON (Param a) where
284− parseJSON = withObject "parameter" $ \o -> Param
285− <$> o .: "location"
286− <*> o .:? "repeated" .!= False
287− <*> parseJSON (Object o)
288− <*> parseJSON (Object o)
289−
290−instance HasInfo (Param a) where
291− info = lens _prmInfo (\s a -> s { _prmInfo = a })
292211
293212data TType
294− = TType Id
213+ = TType Global
295214 | TLit Lit
296215 | TMaybe TType
297216 | TEither TType TType
@@ -314,9 +233,9 @@ data Derive
314233 deriving (Eq, Show)
315234
316235data Solved = Solved
317− { _ident :: Id
318− , _prefix :: Pre
319− , _schema :: Schema Id
236+ { _ident :: Global
237+ , _prefix :: Prefix
238+ , _schema :: Schema Global
320239 , _type :: TType
321240 , _deriving :: [Derive]
322241 }
@@ -329,254 +248,24 @@ instance HasInfo Solved where
329248monoid :: Solved -> Bool
330249monoid = elem DMonoid . _deriving
331250
332−data Syn a = Syn { syntax :: a }
333−
334−instance Pretty a => ToJSON (Syn a) where
335− toJSON = toJSON . prettyPrint . syntax
251+type Seen = Map (CI Text) {- Prefix -} (Set (CI Text)) {- Inhabitants -}
336252
337−data Fun = Fun' Name (Maybe Help) Rendered Rendered
338−
339−instance ToJSON Fun where
340− toJSON (Fun' n h s d) = object
341− [ "name" .= Syn n
342− , "help" .= h
343− , "sig" .= s
344− , "decl" .= d
345− ]
346−
347−data Branch = Branch Name Text Help
348−
349−instance ToJSON Branch where
350− toJSON (Branch n v h) = object
351− [ "name" .= Syn n
352− , "value" .= v
353− , "help" .= Below 6 h
354− ]
355−
356−data Data
357− = Sum Name (Maybe Help) [Branch]
358− | Prod Name (Maybe Help) Rendered Fun [Fun] [Rendered]
359−
360−instance ToJSON Data where
361− toJSON = \case
362− Sum n h bs -> object
363− [ "name" .= Syn n
364− , "type" .= "sum"
365− , "help" .= h
366− , "branches" .= bs
367− ]
368−
369− Prod n h d c ls is -> object
370− [ "name" .= Syn n
371− , "type" .= "prod"
372− , "decl" .= d
373− , "help" .= h
374− , "ctor" .= c
375− , "lenses" .= ls
376− , "instances" .= is
377− ]
378−
379−dataName :: Data -> Name
380−dataName = \case
381− Sum n _ _ -> n
382− Prod n _ _ _ _ _ -> n
383−
384−data Action = Action
385− { _actName :: Name
386− , _actPrettyName :: Text
387− , _actNS :: NS
388− , _actHelp :: Maybe Help
389− , _actAlias :: Rendered
390− , _actData :: Data
253+data Memo = Memo
254+ { _context :: Service (Fix Schema)
255+ , _typed :: Map Global TType
256+ , _derived :: Map Global [Derive]
257+ , _schemas :: Map Global (Schema Global)
258+ , _prefixed :: Map Global Prefix
259+ , _branches :: Seen
260+ , _fields :: Seen
391261 }
392262
393−actionTypeName :: Action -> Name
394−actionTypeName = dataName . _actData
395−
396−instance ToJSON Action where
397− toJSON Action {..} = object
398− [ "name" .= Syn _actName
399− , "prettyName" .= _actPrettyName
400− , "ns" .= _actNS
401− , "help" .= _actHelp
402− , "alias" .= _actAlias
403− , "type" .= _actData
404− ]
263+initial :: Service (Fix Schema) -> Memo
264+initial s = Memo s mempty mempty mempty mempty mempty mempty
405265
406−data API = API
407− { _apiName :: Name
408− , _apiDecl :: Rendered
409− , _apiActions :: Map Name Action
410− , _apiURL :: Fun
411− }
266+makeLenses ''Memo
412267
413−instance ToJSON API where
414− toJSON API {..} = object
415− [ "name" .= Syn _apiName
416− , "decl" .= _apiDecl
417− , "actions" .= sortOn _actName (Map.elems _apiActions)
418− , "url" .= _apiURL
419− ]
420−
421−data Method a = Method
422− { _mId :: Text
423− , _mPath :: Text
424− , _mMethod :: Text
425− , _mDescription :: Maybe Help
426− , _mParameters :: Map Local (Param a)
427− , _mParameterOrder :: [Local]
428− , _mScopes :: [Text]
429− , _mRequest :: Maybe Global
430− , _mResponse :: Maybe Global
431− } deriving (Generic, Functor, Foldable, Traversable)
432−
433−instance FromJSON a => FromJSON (Method a) where
434− parseJSON = withObject "method" $ \o -> Method
435− <$> o .: "id"
436− <*> o .: "path"
437− <*> o .: "httpMethod"
438− <*> o .:? "description"
439− <*> o .:? "parameters" .!= mempty
440− <*> o .:? "parameterOrder" .!= mempty
441− <*> o .:? "scopes" .!= mempty
442− <*> ref o "request"
443− <*> ref o "response"
444− where
445− ref o k = Just <$> (o .: k >>= (.: "$ref"))
446− <|> pure Nothing
447−
448−data Resource a
449− = Top (Map Local (Resource a))
450− | Sub (Map Local (Method a))
451− deriving (Functor, Foldable, Traversable)
452−
453−instance FromJSON a => FromJSON (Resource a) where
454− parseJSON = withObject "resource" $ \o ->
455− Top <$> o .: "resources"
456− <|> Sub <$> o .: "methods"
457−
458−data Service s p r = Service
459− { _svcLibrary :: Text
460− , _svcTitle :: Text
461− , _svcName :: Text
462− , _svcCanonicalName :: Text
463− , _svcDescription :: Help
464− , _svcRevision :: Maybe Text
465− , _svcVersion :: Text
466− , _svcOwnerName :: Text
467− , _svcOwnerDomain :: Text
468− , _svcPackagePath :: Maybe Text
469− , _svcDocumentationLink :: Text
470− , _svcProtocol :: Protocol
471− , _svcBaseUrl :: Text
472− , _svcRootUrl :: Text
473− , _svcServicePath :: Text
474− , _svcBatchPath :: Text
475− , _svcAuth :: Maybe Object
476− , _svcParameters :: p
477− , _svcSchemas :: s
478− , _svcApi :: r
479− } deriving (Generic)
480−
481−instance (FromJSON s, FromJSON p, FromJSON r) => FromJSON (Service s p r) where
482− parseJSON = withObject "service" $ \o -> Service
483− <$> o .: "library"
484− <*> o .: "title"
485− <*> o .: "name"
486− <*> o .: "canonicalName"
487− <*> o .: "description"
488− <*> o .:? "revision"
489− <*> o .: "version"
490− <*> o .: "ownerName"
491− <*> o .: "ownerDomain"
492− <*> o .:? "packagePath"
493− <*> o .: "documentationLink"
494− <*> o .: "protocol"
495− <*> o .: "baseUrl"
496− <*> o .: "rootUrl"
497− <*> o .: "servicePath"
498− <*> o .: "batchPath"
499− <*> o .:? "auth"
500− <*> o .: "parameters"
501− <*> o .: "schemas"
502− <*> parseJSON (Object o)
503−
504−instance (ToJSON s, ToJSON p) => ToJSON (Service s p API) where
505− toJSON s = Object (x <> y)
506− where
507− Object x = genericToJSON (js "_svc") s
508− Object y = object
509− [ "exposedModules" .= exposedModules s
510− ]
268+instance HasService Memo (Fix Schema) where
269+ service = context
511270
512−type Parsed = Service (Map Id (Fix Schema))
513− (Map Local (Param (Fix Schema)))
514− (Resource (Fix Schema))
515−
516−type Flattened = Service [Id] [Param Id] (Resource Id)
517−type Typed = Service [Solved] [Param Solved] (Resource Solved)
518−type Printed = Service [Data] () API
519−
520−svcAbbrev, svcURL :: Service s p r -> Text
521−svcAbbrev = upperHead . renameAbbrev . _svcCanonicalName
522−svcURL = (<> "URL") . lowerHead . svcAbbrev
523−
524−svcActions :: Service s p API -> [Action]
525−svcActions = Map.elems . _apiActions . _svcApi
526−
527−tocImports, typeImports, prodImports, sumImports, actionImports
528− :: Service s p r -> [NS]
529−tocImports _ = ["Network.Google.Prelude"]
530−typeImports s = sort ["Network.Google.Prelude", prodNS s, sumNS s]
531−prodImports s = sort ["Network.Google.Prelude", sumNS s]
532−sumImports _ = sort ["Network.Google.Prelude"]
533−actionImports s = sort ["Network.Google.Prelude", typesNS s]
534−
535−tocNS, typesNS, prodNS, sumNS :: Service s p r -> NS
536−tocNS s = NS $ "Network" : "Google" : Text.split (== '.') (_svcCanonicalName s)
537−typesNS = (<> "Types") . tocNS
538−prodNS = (<> "Product") . typesNS
539−sumNS = (<> "Sum") . typesNS
540−
541−actionNS :: [Text] -> NS
542−actionNS = mappend (NS ["Network", "Google", "API"]) . NS
543−
544−exposedModules :: Service s p API -> [NS]
545−exposedModules s = sort (tocNS s : typesNS s : map _actNS (svcActions s))
546−
547−otherModules :: Service s p r -> [NS]
548−otherModules s = sort [prodNS s, sumNS s]
549−
550−data Library = Library
551− { _libName :: Text
552− , _libTitle :: Text
553− , _libVersions :: Versions
554− , _libServices :: NonEmpty Printed
555− }
556−
557−instance ToJSON Library where
558− toJSON Library{..} = object
559− [ "libraryName" .= _libName
560− , "libraryTitle" .= _libTitle
561− , "libraryVersion" .= _libraryVersion _libVersions
562− , "libraryDescriptions" .= map (Desc 4 . _svcDescription) (NE.toList _libServices)
563− , "coreVersion" .= _coreVersion _libVersions
564− , "clientVersion" .= _clientVersion _libVersions
565− , "exposedModules" .= concatMap exposedModules (NE.toList _libServices)
566− , "otherModules" .= concatMap otherModules (NE.toList _libServices)
567− ]
568−
569−merge :: Versions -> [Printed] -> [Library]
570−merge v = map go . groupBy (on (==) _svcLibrary)
571− where
572− go [x] = mk x
573− go (x:xs) = (mk x) { _libServices = x :| xs }
574− -- FIXME:
575− go [] = error "Empty merge set!"
576−
577− mk x = Library
578− { _libName = renameLibrary (_svcLibrary x)
579− , _libTitle = renameTitle (_svcTitle x)
580− , _libVersions = v
581− , _libServices = x :| []
582− }
271+type AST = ExceptT Error (State Memo)
gen/src/Gen/Types/Data.hsnew file+154
@@ -0,0 +1,154 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveFoldable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE DeriveTraversable #-}
6+{-# LANGUAGE ExtendedDefaultRules #-}
7+{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+{-# LANGUAGE KindSignatures #-}
11+{-# LANGUAGE LambdaCase #-}
12+{-# LANGUAGE OverloadedStrings #-}
13+{-# LANGUAGE RecordWildCards #-}
14+{-# LANGUAGE TemplateHaskell #-}
15+
16+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
17+
18+-- Module : Gen.Types.Data
19+-- Copyright : (c) 2015 Brendan Hay
20+-- License : Mozilla Public License, v. 2.0.
21+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
22+-- Stability : provisional
23+-- Portability : non-portable (GHC extensions)
24+
25+module Gen.Types.Data where
26+
27+import Control.Applicative
28+import Control.Lens hiding ((.=))
29+import Data.Aeson hiding (Array, Bool, String)
30+import qualified Data.Aeson as A
31+import Data.Aeson.TH
32+import Data.Char
33+import Data.Function (on)
34+import qualified Data.HashMap.Strict as Map
35+import qualified Data.HashSet as Set
36+import Data.List (groupBy, sort, sortOn)
37+import Data.List.NonEmpty (NonEmpty (..))
38+import qualified Data.List.NonEmpty as NE
39+import Data.Maybe
40+import Data.Ord
41+import Data.Semigroup ((<>))
42+import Data.Text (Text)
43+import qualified Data.Text as Text
44+import qualified Data.Text.Lazy as LText
45+import qualified Data.Text.Lazy.Builder as Build
46+import Data.Text.Manipulate
47+import qualified Data.Text.Read as Read
48+import qualified Filesystem.Path.CurrentOS as Path
49+import Formatting
50+import Gen.Orphans ()
51+import Gen.Text
52+import Gen.TH
53+import Gen.Types.Help
54+import Gen.Types.Id
55+import Gen.Types.NS
56+import GHC.Generics
57+import GHC.TypeLits
58+import Language.Haskell.Exts (Name)
59+import Language.Haskell.Exts.Pretty (Pretty, prettyPrint)
60+import Prelude hiding (Enum)
61+import Text.EDE (Template)
62+
63+default (Text)
64+
65+type Rendered = LText.Text
66+
67+data Syn a = Syn { syntax :: a }
68+
69+instance Pretty a => ToJSON (Syn a) where
70+ toJSON = toJSON . prettyPrint . syntax
71+
72+data Fun = Fun' Name (Maybe Help) Rendered Rendered
73+
74+instance ToJSON Fun where
75+ toJSON (Fun' n h s d) = object
76+ [ "name" .= Syn n
77+ , "help" .= h
78+ , "sig" .= s
79+ , "decl" .= d
80+ ]
81+
82+data Branch = Branch Name Text Help
83+
84+instance ToJSON Branch where
85+ toJSON (Branch n v h) = object
86+ [ "name" .= Syn n
87+ , "value" .= v
88+ , "help" .= Below 6 h
89+ ]
90+
91+data Data
92+ = Sum Name (Maybe Help) [Branch]
93+ | Prod Name (Maybe Help) Rendered Fun [Fun] [Rendered]
94+
95+instance ToJSON Data where
96+ toJSON = \case
97+ Sum n h bs -> object
98+ [ "name" .= Syn n
99+ , "type" .= "sum"
100+ , "help" .= h
101+ , "branches" .= bs
102+ ]
103+
104+ Prod n h d c ls is -> object
105+ [ "name" .= Syn n
106+ , "type" .= "prod"
107+ , "decl" .= d
108+ , "help" .= h
109+ , "ctor" .= c
110+ , "lenses" .= ls
111+ , "instances" .= is
112+ ]
113+
114+dataName :: Data -> Name
115+dataName = \case
116+ Sum n _ _ -> n
117+ Prod n _ _ _ _ _ -> n
118+
119+data Action = Action
120+ { _actName :: Name
121+ , _actPrettyName :: Text
122+ , _actNS :: NS
123+ , _actHelp :: Maybe Help
124+ , _actAlias :: Rendered
125+ , _actData :: Data
126+ }
127+
128+actionTypeName :: Action -> Name
129+actionTypeName = dataName . _actData
130+
131+instance ToJSON Action where
132+ toJSON Action {..} = object
133+ [ "name" .= Syn _actName
134+ , "prettyName" .= _actPrettyName
135+ , "ns" .= _actNS
136+ , "help" .= _actHelp
137+ , "alias" .= _actAlias
138+ , "type" .= _actData
139+ ]
140+
141+-- data API = API
142+-- { _apiName :: Name
143+-- , _apiDecl :: Rendered
144+-- , _apiActions :: Map Name Action
145+-- , _apiURL :: Fun
146+-- }
147+
148+-- instance ToJSON API where
149+-- toJSON API {..} = object
150+-- [ "name" .= Syn _apiName
151+-- , "decl" .= _apiDecl
152+-- , "actions" .= sortOn _actName (Map.elems _apiActions)
153+-- , "url" .= _apiURL
154+-- ]
gen/src/Gen/Types/Id.hs+47−85
@@ -11,7 +11,14 @@
1111-- Stability : provisional
1212-- Portability : non-portable (GHC extensions)
1313
14−module Gen.Types.Id where
14+module Gen.Types.Id
15+ ( Prefix (..)
16+ , Global
17+ , Local
18+ , gid
19+ , lid
20+ , reference
21+ ) where
1522
1623import Control.Applicative
1724import Control.Lens hiding (pre, (.=))
@@ -36,6 +43,7 @@ import qualified Data.Text.Lazy as LText
3643import qualified Data.Text.Lazy.Builder as Build
3744import Data.Text.Manipulate
3845import Formatting
46+import Gen.Orphans ()
3947import Gen.Text
4048import Gen.Types.Map
4149import GHC.Generics
@@ -43,47 +51,49 @@ import Language.Haskell.Exts.Build
4351import Language.Haskell.Exts.Pretty (prettyPrint)
4452import Language.Haskell.Exts.Syntax (Name)
4553
46−vname :: Text -> Text -> (Name, Id, [Text])
47−vname abrv r = (dname (g (n <> "API")), g (n <> "'"), ns)
48− where
49− g = Free . Global
50− n = mconcat (drop 1 ns)
54+-- vname :: Text -> Text -> (Name, Id, [Text])
55+-- vname abrv r = (dname (g (n <> "API")), g (n <> "'"), ns)
56+-- where
57+-- g = Free . Global
58+-- n = mconcat (drop 1 ns)
5159
52− ns | CI.mk e == CI.mk x = e:xs
53− | otherwise = x:xs
54− where
55− e = Text.replace "." "" abrv
56− x:xs = map (upperAcronym . upperHead) $ Text.split (== '.') r
60+-- ns | CI.mk e == CI.mk x = e:xs
61+-- | otherwise = x:xs
62+-- where
63+-- e = Text.replace "." "" abrv
64+-- x:xs = map (upperAcronym . upperHead) $ Text.split (== '.') r
5765
58−dname, cname :: Id -> Name
59−dname = name . Text.unpack . upperHead . idToText
60−cname = name . Text.unpack . renameReserved . lowerHead . idToText
66+-- dname, cname :: Id -> Name
67+-- dname = name . Text.unpack . upperHead . idToText
68+-- cname = name . Text.unpack . renameReserved . lowerHead . idToText
6169
62−bname :: Pre -> Text -> Name
63−bname (Pre p) = name
64− . Text.unpack
65− . mappend (Text.toUpper p)
66− . renameBranch
70+-- bname :: Pre -> Text -> Name
71+-- bname (Pre p) = name
72+-- . Text.unpack
73+-- . mappend (Text.toUpper p)
74+-- . renameBranch
6775
68−fname, lname, pname :: Pre -> Local -> Name
69−fname = pre (Text.cons '_' . renameField)
70−lname = pre renameField
71−pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)
76+-- fname, lname, pname :: Pre -> Local -> Name
77+-- fname = pre (Text.cons '_' . renameField)
78+-- lname = pre renameField
79+-- pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)
7280
73−apretty :: Local -> Local -> Text
74−apretty p l = upperHead (local l) <> " " <> upperHead (local p)
81+-- apretty :: Local -> Local -> Text
82+-- apretty p l = upperHead (local l) <> " " <> upperHead (local p)
83+
84+-- pre :: (Text -> Text) -> Pre -> Local -> Name
85+-- pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local
86+
87+newtype Prefix = Prefix Text
88+ deriving (Show, Monoid)
7589
76−pre :: (Text -> Text) -> Pre -> Local -> Name
77−pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local
7890
7991newtype Global = Global { global :: Text }
8092 deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)
8193
82−instance FromJSON a => FromJSON (Map Global a) where
83− parseJSON = fmap (fromMap Global) . parseJSON
84−
85−instance ToJSON a => ToJSON (Map Global a) where
86− toJSON = toJSON . toMap global
94+instance TextKey Global where
95+ toKey = Global
96+ fromKey = global
8797
8898gid :: Format a (Global -> a)
8999gid = later (Build.fromText . global)
@@ -91,60 +101,12 @@ gid = later (Build.fromText . global)
91101newtype Local = Local { local :: Text }
92102 deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)
93103
94−instance FromJSON a => FromJSON (Map Local a) where
95− parseJSON = fmap (fromMap Local) . parseJSON
96−
97−instance ToJSON a => ToJSON (Map Local a) where
98− toJSON = toJSON . toMap local
104+instance TextKey Local where
105+ toKey = Local
106+ fromKey = local
99107
100108lid :: Format a (Local -> a)
101109lid = later (Build.fromText . local)
102110
103−data Id
104− = Free Global
105− | Bound Global (NonEmpty Local)
106− deriving (Eq, Show, Generic)
107−
108−instance Hashable Id
109−
110−instance IsString Id where
111− fromString = Free . Global . fromString
112−
113−instance FromJSON a => FromJSON (Map Id a) where
114− parseJSON = fmap (fromMap (Free . Global)) . parseJSON
115−
116−instance ToJSON a => ToJSON (Map Id a) where
117− toJSON = toJSON . toMap idToText
118−
119−newtype Pre = Pre Text
120− deriving (Show, Monoid)
121−
122−mkId :: Global -> [Local] -> Id
123−mkId g = \case
124− [] -> Free g
125− x:xs -> Bound g (x :| xs)
126−
127−mkProp :: Id -> Local -> Id
128−mkProp n x =
129− case n of
130− Free g -> Bound g (x :| [])
131− Bound g xs -> Bound g (NE.cons x xs)
132−
133−revProp :: Id -> Local
134−revProp = \case
135− Free g -> Local (global g)
136− Bound _ xs -> let x :| _ = NE.reverse xs in x
137−
138−idToText :: Id -> Text
139−idToText = renameReserved . upperHead . \case
140− Free g -> global g
141− Bound g ls -> mconcat (global g : map (upperHead . local) (NE.toList ls))
142−
143−fid :: Format a (Id -> a)
144−fid = later (Build.fromText . idToText)
145−
146−fromMap :: (Eq a, Hashable a) => (Text -> a) -> Map Text b -> Map a b
147−fromMap f = Map.fromList . map (first f) . Map.toList
148−
149−toMap :: (a -> Text) -> Map a b -> Map Text b
150−toMap f = Map.fromList . map (first f) . Map.toList
111+reference :: Global -> Local -> Global
112+reference (Global g) (Local l) = Global (g <> "." <> l)
gen/src/Gen/Types/Map.hs+20−1
@@ -1,4 +1,7 @@
1−-- Module : Gen.Types.Map
1+{-# LANGUAGE FlexibleInstances #-}
2+
3+
4+ -- Module : Gen.Types.Map
25-- Copyright : (c) 2013-2015 Brendan Hay
36-- License : This Source Code Form is subject to the terms of
47-- the Mozilla Public License, v. 2.0.
@@ -11,9 +14,14 @@
1114module Gen.Types.Map where
1215
1316import Control.Lens
17+import Control.Monad
18+import Data.Aeson
19+import Data.Aeson.Types
20+import Data.Bifunctor
1421import Data.Hashable
1522import qualified Data.HashMap.Strict as Map
1623import Data.Maybe
24+import Data.Text (Text)
1725
1826type Map = Map.HashMap
1927
@@ -29,3 +37,14 @@ kvTraverseMaybe :: (Applicative f, Eq k, Hashable k)
2937 -> f (Map k b)
3038kvTraverseMaybe f = fmap (Map.map fromJust . Map.filter isJust)
3139 . Map.traverseWithKey f
40+
41+class (Hashable a, Eq a) => TextKey a where
42+ toKey :: Text -> a
43+ fromKey :: a -> Text
44+
45+instance (TextKey k, FromJSON v) => FromJSON (Map k v) where
46+ parseJSON = fmap (Map.fromList . map (first toKey) . Map.toList)
47+ . parseJSON
48+
49+instance (TextKey k, ToJSON v) => ToJSON (Map k v) where
50+ toJSON = toJSON . map (first fromKey) . Map.toList
gen/src/Gen/Types/NS.hs+4−17
@@ -7,7 +7,10 @@
77-- Stability : provisional
88-- Portability : non-portable (GHC extensions)
99
10−module Gen.Types.NS where
10+module Gen.Types.NS
11+ ( NS
12+ , mkNS
13+ ) where
1114
1215import Data.Aeson
1316import Data.Aeson.Types
@@ -48,19 +51,3 @@ instance FromJSON NS where
4851
4952instance ToJSON NS where
5053 toJSON (NS xs) = toJSON (Text.intercalate "." xs)
51−
52−options :: Options
53−options = defaultOptions
54− { constructorTagModifier = map toLower
55− , fieldLabelModifier = \s ->
56− let x:xs = dropWhile (not . isUpper) s in toLower x : xs
57− }
58−
59−-- Wut?
60−js :: String -> Options
61−js pre = defaultOptions
62− { constructorTagModifier = map toLower
63− , fieldLabelModifier = \s ->
64− let x:xs = drop (length pre) s
65− in toLower x : xs
66− }
gen/src/Gen/Types/Schema.hsnew file+489
@@ -0,0 +1,489 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveFoldable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE DeriveTraversable #-}
6+{-# LANGUAGE ExtendedDefaultRules #-}
7+{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE FunctionalDependencies #-}
10+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11+{-# LANGUAGE KindSignatures #-}
12+{-# LANGUAGE LambdaCase #-}
13+{-# LANGUAGE MultiParamTypeClasses #-}
14+{-# LANGUAGE OverloadedStrings #-}
15+{-# LANGUAGE RecordWildCards #-}
16+{-# LANGUAGE TemplateHaskell #-}
17+
18+-- Module : Gen.Types.Schema
19+-- Copyright : (c) 2015 Brendan Hay
20+-- License : Mozilla Public License, v. 2.0.
21+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
22+-- Stability : provisional
23+-- Portability : non-portable (GHC extensions)
24+
25+module Gen.Types.Schema where
26+
27+import Control.Applicative
28+import Control.Lens hiding ((.=))
29+import Data.Aeson hiding (Array, Bool, Object,
30+ String)
31+import qualified Data.Aeson as A
32+import Data.Aeson.TH
33+import Data.Char
34+import Data.Function (on)
35+import Data.Hashable
36+import qualified Data.HashMap.Strict as Map
37+import qualified Data.HashSet as Set
38+import Data.List (groupBy, sort, sortOn)
39+import Data.List.NonEmpty (NonEmpty (..))
40+import qualified Data.List.NonEmpty as NE
41+import Data.Maybe
42+import Data.Ord
43+import Data.Semigroup ((<>))
44+import Data.Text (Text)
45+import qualified Data.Text as Text
46+import qualified Data.Text.Lazy as LText
47+import qualified Data.Text.Lazy.Builder as Build
48+import Data.Text.Manipulate
49+import qualified Data.Text.Read as Read
50+import qualified Filesystem.Path.CurrentOS as Path
51+import Formatting
52+import Gen.Orphans ()
53+import Gen.Text
54+import Gen.TH
55+import Gen.Types.Help
56+import Gen.Types.Id
57+import Gen.Types.Map
58+import Gen.Types.NS
59+import GHC.Generics
60+import GHC.TypeLits
61+import Language.Haskell.Exts (Name)
62+import Language.Haskell.Exts.Pretty (Pretty, prettyPrint)
63+import Prelude hiding (Enum)
64+import Text.EDE (Template)
65+
66+newtype Fix f = Fix (f (Fix f))
67+
68+keyless :: Map Text a -> [a]
69+keyless = Map.elems
70+
71+data Location
72+ = Query
73+ | Path
74+ deriving (Eq, Show)
75+
76+deriveJSON options ''Location
77+
78+newtype Ann = Ann { annRequired :: [Local] }
79+ deriving (Eq, Show, Monoid)
80+
81+deriveJSON options ''Ann
82+
83+data Info = Info
84+ { _iId :: Maybe Global
85+ , _iDescription :: Maybe Help
86+ , _iDefault :: Maybe Text
87+ , _iRequired :: Bool
88+ , _iPattern :: Maybe Text
89+ , _iMinimum :: Maybe Text
90+ , _iMaximum :: Maybe Text
91+ , _iRepeated :: Bool
92+ , _iAnnotations :: Ann
93+ } deriving (Eq, Show)
94+
95+makeClassy ''Info
96+
97+instance FromJSON Info where
98+ parseJSON = withObject "info" $ \o -> Info
99+ <$> o .: "id"
100+ <*> o .:? "description"
101+ <*> o .:? "default"
102+ <*> o .:? "required" .!= False
103+ <*> o .:? "pattern"
104+ <*> o .:? "minimum"
105+ <*> o .:? "maximum"
106+ <*> o .:? "repeated" .!= False
107+ <*> o .:? "annotations" .!= mempty
108+
109+data Schema a
110+ = SRef Info Ref
111+ | SLit Info Lit
112+ | SEnm Info Enm
113+ | SArr Info (Arr a)
114+ | SObj Info (Obj a)
115+ deriving (Eq, Show)
116+
117+instance FromJSON a => FromJSON (Schema a) where
118+ parseJSON o = do
119+ i <- parseJSON o
120+ SRef i <$> parseJSON o
121+ <|> SLit i <$> parseJSON o
122+ <|> SEnm i <$> parseJSON o
123+ <|> SArr i <$> parseJSON o
124+ <|> SObj i <$> parseJSON o
125+
126+instance HasInfo (Schema a) where
127+ info = lens f (flip g)
128+ where
129+ f = \case
130+ SRef i _ -> i
131+ SLit i _ -> i
132+ SEnm i _ -> i
133+ SArr i _ -> i
134+ SObj i _ -> i
135+
136+ g i = \case
137+ SRef _ x -> SRef i x
138+ SLit _ x -> SLit i x
139+ SEnm _ x -> SEnm i x
140+ SArr _ x -> SArr i x
141+ SObj _ x -> SObj i x
142+
143+newtype Ref = Ref { ref :: Global }
144+ deriving (Eq, Show)
145+
146+instance FromJSON Ref where
147+ parseJSON = withObject "ref" (fmap Ref . (.: "$ref"))
148+
149+data Lit
150+ = Text
151+ | Bool
152+ | Float
153+ | Double
154+ | Byte
155+ | UInt32
156+ | UInt64
157+ | Int32
158+ | Int64
159+ | Date
160+ | Time
161+ deriving (Eq, Show)
162+
163+instance FromJSON Lit where
164+ parseJSON = withObject "literal" $ \o -> do
165+ t <- o .: "format" <|> o .: "type"
166+ case t of
167+ -- Types
168+ "string" -> pure Text
169+ "boolean" -> pure Bool
170+
171+ -- Formats
172+ "float" -> pure Float
173+ "double" -> pure Double
174+ "byte" -> pure Byte
175+ "uint32" -> pure UInt32
176+ "uint64" -> pure UInt64
177+ "int32" -> pure Int32
178+ "int64" -> pure Int64
179+ "date" -> pure Date
180+ "date-time" -> pure Time
181+
182+ _ -> fail $
183+ "Unable to parse Literal from: " ++ Text.unpack t
184+
185+newtype Enm = Enm { _eValues :: [(Text, Help)] }
186+ deriving (Eq, Show)
187+
188+instance FromJSON Enm where
189+ parseJSON = withObject "enum" $ \o -> do
190+ vs <- o .: "enum"
191+ ds <- o .: "enumDescriptions"
192+ pure $! Enm (zip vs (ds ++ repeat mempty))
193+
194+newtype Arr a = Arr { _aItem :: a }
195+ deriving (Eq, Show)
196+
197+instance FromJSON a => FromJSON (Arr a) where
198+ parseJSON = withObject "array" (fmap Arr . (.: "item"))
199+
200+data Obj a = Obj
201+ { _oAdditionalProperties :: Maybe a
202+ , _oProperties :: Map Local a
203+ } deriving (Eq, Show)
204+
205+deriveFromJSON options ''Obj
206+
207+data Param a = Param
208+ { _pLocation :: Location
209+ , _pParam :: a
210+ } deriving (Eq, Show)
211+
212+makeLenses ''Param
213+
214+instance FromJSON a => FromJSON (Param a) where
215+ parseJSON = withObject "param" $ \o -> Param
216+ <$> o .: "location"
217+ <*> parseJSON (A.Object o)
218+
219+instance HasInfo a => HasInfo (Param a) where
220+ info = pParam . info
221+
222+data MediaUpload = MediaUpload
223+ { _muAccept :: [Text]
224+ , _muMaxSize :: Text
225+ , _muResumablePath :: Text
226+ , _muSimplePath :: Text
227+ } deriving (Eq, Show)
228+
229+instance FromJSON MediaUpload where
230+ parseJSON = withObject "mediaUpload" $ \o -> MediaUpload
231+ <$> o .: "accept"
232+ <*> o .: "maxSize"
233+ <*> (o .: "protocols" >>= (.: "resumable") >>= (.: "path"))
234+ <*> (o .: "protocols" >>= (.: "simple") >>= (.: "path"))
235+
236+data Method a = Method
237+ { _mId :: Global
238+ , _mPath :: Text
239+ , _mHttpMethod :: Text
240+ , _mDescription :: Help
241+ , _mParameters :: Map Local (Param a)
242+ , _mParameterOrder :: [Local]
243+ , _mRequest :: Maybe Ref
244+ , _mResponse :: Maybe Ref
245+ , _mScopes :: [Text]
246+ , _mSupportsMediaUpload :: Bool
247+ , _mSupportsMediaDownload :: Bool
248+ , _mMediaUpload :: Maybe MediaUpload
249+ , _mSupportsSubscription :: Bool
250+ } deriving (Eq, Show)
251+
252+instance FromJSON a => FromJSON (Method a) where
253+ parseJSON = withObject "method" $ \o -> Method
254+ <$> o .: "id"
255+ <*> o .: "path"
256+ <*> o .: "httpMethod"
257+ <*> o .: "description"
258+ <*> o .:? "parameters" .!= mempty
259+ <*> o .:? "parameterOrder" .!= mempty
260+ <*> o .:? "request"
261+ <*> o .:? "response"
262+ <*> o .:? "scopes" .!= mempty
263+ <*> o .:? "supportsMediaUpload" .!= False
264+ <*> o .:? "supportsMediaDownload" .!= False
265+ <*> o .:? "mediaUpload"
266+ <*> o .:? "supportsSubscription" .!= False
267+
268+data Resource a b = Resource
269+ { _rResources :: Map a (Resource Local b)
270+ , _rMethods :: [Method b]
271+ } deriving (Eq, Show)
272+
273+instance (TextKey a, FromJSON a, FromJSON b) => FromJSON (Resource a b) where
274+ parseJSON = withObject "resource" $ \o -> Resource
275+ <$> o .:? "resources" .!= mempty
276+ <*> (o .:? "methods" .!= mempty <&> keyless)
277+
278+newtype OAuth2 = OAuth2 { scopes :: Map Text Text }
279+ deriving (Eq, Show)
280+
281+instance FromJSON OAuth2 where
282+ parseJSON = withObject "oauth2" $ \o ->
283+ o .: "oauth2" >>=
284+ withObject "scopes" (.: "scopes")
285+
286+data Description a = Description
287+ { _dKind :: Text
288+ , _dDiscoveryVersion :: Text
289+ , _dId :: Text
290+ , _dName :: Text
291+ , _dVersion :: Text
292+ , _dRevision :: Text
293+ , _dTitle :: Text
294+ , _dDescription :: Help
295+ , _dIcons :: Map Text Text
296+ , _dDocumentationLink :: Text
297+ , _dLabels :: Text
298+ , _dProtocol :: Text
299+ , _dBaseUrl :: Text
300+ , _dRootUrl :: Text
301+ , _dServicePath :: Text
302+ , _dBatchPath :: Text
303+ , _dParameters :: Map Local (Param a)
304+ , _dAuth :: OAuth2
305+ , _dFeatures :: [Text]
306+ , _dSchemas :: Map Global (Schema a)
307+ , _dResources :: Map Global (Resource Global a)
308+ , _dMethods :: [Method a]
309+ } deriving (Eq, Show)
310+
311+makeClassy ''Description
312+
313+instance FromJSON a => FromJSON (Description a) where
314+ parseJSON = withObject "description" $ \o -> Description
315+ <$> o .: "kind"
316+ <*> o .: "discoveryVersion"
317+ <*> o .: "id"
318+ <*> o .: "name"
319+ <*> o .: "version"
320+ <*> o .: "revision"
321+ <*> o .: "title"
322+ <*> o .: "description"
323+ <*> o .: "icons"
324+ <*> o .: "documentationLink"
325+ <*> o .: "labels"
326+ <*> o .: "protocol"
327+ <*> o .: "baseUrl"
328+ <*> o .: "rootUrl"
329+ <*> o .: "servicePath"
330+ <*> o .: "batchPath"
331+ <*> o .:? "parameters" .!= mempty
332+ <*> o .: "auth"
333+ <*> o .:? "features" .!= mempty
334+ <*> o .:? "schemas" .!= mempty
335+ <*> o .:? "resources" .!= mempty
336+ <*> (o .:? "methods" .!= mempty <&> keyless)
337+
338+data Service a = Service
339+ { _sLibrary :: Text
340+ , _sCanonicalName :: Text
341+ , _sOwnerName :: Text
342+ , _sOwnerDomain :: Text
343+ , _sPackagePath :: Maybe Text
344+ , _sDescription :: (Description a)
345+ } deriving (Eq, Show)
346+
347+makeClassy ''Service
348+
349+instance FromJSON a => FromJSON (Service a) where
350+ parseJSON = withObject "service" $ \o -> Service
351+ <$> o .: "library"
352+ <*> (o .: "canonicalName" <&> upperHead . renameAbbrev)
353+ <*> o .: "ownerName"
354+ <*> o .: "ownerDomain"
355+ <*> o .: "packagePath"
356+ <*> parseJSON (A.Object o)
357+
358+instance HasDescription (Service a) a where
359+ description = sDescription
360+
361+urlName :: Service a -> Text
362+urlName = (<> "URL") . lowerHead . _sCanonicalName
363+
364+-- data Method a = Method
365+-- { _mId :: Text
366+-- , _mPath :: Text
367+-- , _mMethod :: Text
368+-- , _mDescription :: Maybe Help
369+-- , _mParameters :: Map Local (Param a)
370+-- , _mParameterOrder :: [Local]
371+-- , _mScopes :: [Text]
372+-- , _mRequest :: Maybe Global
373+-- , _mResponse :: Maybe Global
374+-- } deriving (Generic, Functor, Foldable, Traversable)
375+
376+-- instance FromJSON a => FromJSON (Method a) where
377+-- parseJSON = withObject "method" $ \o -> Method
378+-- <$> o .: "id"
379+-- <*> o .: "path"
380+-- <*> o .: "httpMethod"
381+-- <*> o .:? "description"
382+-- <*> o .:? "parameters" .!= mempty
383+-- <*> o .:? "parameterOrder" .!= mempty
384+-- <*> o .:? "scopes" .!= mempty
385+-- <*> ref o "request"
386+-- <*> ref o "response"
387+-- where
388+-- ref o k = Just <$> (o .: k >>= (.: "$ref"))
389+-- <|> pure Nothing
390+
391+-- data Resource a
392+-- = Top (Map Local (Resource a))
393+-- | Sub (Map Local (Method a))
394+-- deriving (Functor, Foldable, Traversable)
395+
396+-- instance FromJSON a => FromJSON (Resource a) where
397+-- parseJSON = withObject "resource" $ \o ->
398+-- Top <$> o .: "resources"
399+-- <|> Sub <$> o .: "methods"
400+
401+-- data Service s p r = Service
402+-- { _svcLibrary :: Text
403+-- , _svcTitle :: Text
404+-- , _svcName :: Text
405+-- , _svcCanonicalName :: Text
406+-- , _svcDescription :: Help
407+-- , _svcRevision :: Maybe Text
408+-- , _svcVersion :: Text
409+-- , _svcOwnerName :: Text
410+-- , _svcOwnerDomain :: Text
411+-- , _svcPackagePath :: Maybe Text
412+-- , _svcDocumentationLink :: Text
413+-- , _svcProtocol :: Protocol
414+-- , _svcBaseUrl :: Text
415+-- , _svcRootUrl :: Text
416+-- , _svcServicePath :: Text
417+-- , _svcBatchPath :: Text
418+-- , _svcAuth :: Maybe Object
419+-- , _svcParameters :: p
420+-- , _svcSchemas :: s
421+-- , _svcApi :: r
422+-- } deriving (Generic)
423+
424+-- type Parsed = Service (Map Id (Fix Schema))
425+-- (Map Local (Param (Fix Schema)))
426+-- (Resource (Fix Schema))
427+
428+-- type Flattened = Service [Id] [Param Id] (Resource Id)
429+-- type Typed = Service [Solved] [Param Solved] (Resource Solved)
430+-- type Printed = Service [Data] () API
431+
432+-- instance (FromJSON s, FromJSON p, FromJSON r) => FromJSON (Service s p r) where
433+-- parseJSON = withObject "service" $ \o -> Service
434+-- <$> o .: "library"
435+-- <*> o .: "title"
436+-- <*> o .: "name"
437+-- <*> o .: "canonicalName"
438+-- <*> o .: "description"
439+-- <*> o .:? "revision"
440+-- <*> o .: "version"
441+-- <*> o .: "ownerName"
442+-- <*> o .: "ownerDomain"
443+-- <*> o .:? "packagePath"
444+-- <*> o .: "documentationLink"
445+-- <*> o .: "protocol"
446+-- <*> o .: "baseUrl"
447+-- <*> o .: "rootUrl"
448+-- <*> o .: "servicePath"
449+-- <*> o .: "batchPath"
450+-- <*> o .:? "auth"
451+-- <*> o .: "parameters"
452+-- <*> o .: "schemas"
453+-- <*> parseJSON (Object o)
454+
455+-- instance (ToJSON s, ToJSON p) => ToJSON (Service s p API) where
456+-- toJSON s = Object (x <> y)
457+-- where
458+-- Object x = genericToJSON (js "_svc") s
459+-- Object y = object
460+-- [ "exposedModules" .= exposedModules s
461+-- ]
462+
463+-- type Parsed = Service (Map Id (Fix Schema))
464+-- (Map Local (Param (Fix Schema)))
465+-- (Resource (Fix Schema))
466+
467+-- type Flattened = Service [Id] [Param Id] (Resource Id)
468+-- type Typed = Service [Solved] [Param Solved] (Resource Solved)
469+-- type Printed = Service [Data] () API
470+
471+-- data Library = Library
472+-- { _libName :: Text
473+-- , _libTitle :: Text
474+-- , _libVersions :: Versions
475+-- , _libServices :: NonEmpty Printed
476+-- }
477+
478+-- instance ToJSON Library where
479+-- toJSON Library{..} = object
480+-- [ "libraryName" .= _libName
481+-- , "libraryTitle" .= _libTitle
482+-- , "libraryVersion" .= _libraryVersion _libVersions
483+-- , "libraryDescriptions" .= map (Desc 4 . _svcDescription) (NE.toList _libServices)
484+-- , "coreVersion" .= _coreVersion _libVersions
485+-- , "clientVersion" .= _clientVersion _libVersions
486+-- , "exposedModules" .= concatMap exposedModules (NE.toList _libServices)
487+-- , "otherModules" .= concatMap otherModules (NE.toList _libServices)
488+-- ]
489+