git.iko.soy/gogol
on develop help sign in
Reworking to support JSON Schema specification
3903e2eBrendan Hay
gen/gogol-gen.cabal+15−14
compare with develop
unifiedsplit
@@ -22,20 +22,21 @@ executable gogol-gen
22
22
23 other-modules:
23 other-modules:
24 Gen.AST
24 Gen.AST
25− , Gen.Formatting
25+ -- , Gen.Formatting
26− , Gen.IO
26+ -- , Gen.IO
27− , Gen.JSON
27+ -- , Gen.JSON
28− , Gen.Orphans
28+ -- , Gen.Orphans
29− , Gen.Schema
29+ -- , Gen.Schema
30− , Gen.Solve
30+ -- , Gen.Solve
31− , Gen.Syntax
31+ -- , Gen.Syntax
32− , Gen.Text
32+ -- , Gen.Text
33+ -- , Gen.TH
33− , Gen.Tree
34+ -- , Gen.Tree
34− , Gen.Types
35+ -- , Gen.Types
35− , Gen.Types.Help
36+ -- , Gen.Types.Help
36− , Gen.Types.Id
37+ -- , Gen.Types.Id
37− , Gen.Types.Map
38+ -- , Gen.Types.Map
38− , Gen.Types.NS
39+ -- , Gen.Types.NS
39
40
40 ghc-options: -Wall -threaded
41 ghc-options: -Wall -threaded
41
42
gen/src/Gen/AST.hs+228−227
@@ -10,7 +10,6 @@
10{-# LANGUAGE RecordWildCards #-}
10{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE TemplateHaskell #-}
11{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TupleSections #-}
12{-# LANGUAGE TupleSections #-}
13−{-# LANGUAGE ViewPatterns #-}
14
13
15-- Module : Gen.AST
14-- Module : Gen.AST
16-- Copyright : (c) 2015 Brendan Hay
15-- Copyright : (c) 2015 Brendan Hay
@@ -36,235 +35,237 @@ import qualified Data.Text.Lazy.Builder as Build
36import Debug.Trace
35import Debug.Trace
37import Gen.Formatting
36import Gen.Formatting
38import Gen.Solve
37import Gen.Solve
39−import Gen.Syntax
38+-- import Gen.Syntax
39+import Gen.AST.Flatten
40import Gen.Types
40import Gen.Types
41import HIndent
41import HIndent
42import Language.Haskell.Exts.Build (name)
42import Language.Haskell.Exts.Build (name)
43import Language.Haskell.Exts.Pretty
43import Language.Haskell.Exts.Pretty
44import Prelude hiding (sum)
44import Prelude hiding (sum)
45
45
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+
46−runAST :: Parsed -> Either Error Printed
114+-- runAST :: Parsed -> Either Error Printed
47−runAST svc = evalState (runExceptT go) initial
115+-- runAST svc = evalState (runExceptT go) initial
48− where
116+-- where
49− go = do
117+-- go = do
50− x <- flatten svc
118+-- x <- flatten svc
51− reserve x
119+-- reserve x
52− solveAll x >>= render
120+-- solveAll x >>= render
53−
121+
54−render :: Typed -> AST Printed
122+-- render :: Typed -> AST Printed
55−render svc = do
123+-- render svc = do
56− x <- traverse typ (_svcSchemas svc)
124+-- x <- traverse typ (_svcSchemas svc)
57− y <- api (_svcApi svc)
125+-- y <- api (_svcApi svc)
58−
126+
59− let as = map actionTypeName (Map.elems (_apiActions y))
127+-- let as = map actionTypeName (Map.elems (_apiActions y))
60− f d = elem (dataName d) as
128+-- f d = elem (dataName d) as
61− z = trace (show as) $ filter (not . f) (catMaybes x)
129+-- z = trace (show as) $ filter (not . f) (catMaybes x)
62−
130+
63− return $! svc { _svcSchemas = z, _svcParameters = (), _svcApi = y }
131+-- return $! svc { _svcSchemas = z, _svcParameters = (), _svcApi = y }
64− where
132+-- where
65− typ :: Solved -> AST (Maybe Data)
133+-- typ :: Solved -> AST (Maybe Data)
66− typ Solved{..} = case _schema of
134+-- typ Solved{..} = case _schema of
67− Arr {} -> pure Nothing
135+-- Arr {} -> pure Nothing
68− Ref {} -> pure Nothing
136+-- Ref {} -> pure Nothing
69− Any {} -> pure Nothing
137+-- Any {} -> pure Nothing
70− Lit {} -> pure Nothing
138+-- Lit {} -> pure Nothing
71− Enum i vs ds -> pure . Just $
139+-- Enum i vs ds -> pure . Just $
72− Sum (dname _ident) (i ^. description) $
140+-- Sum (dname _ident) (i ^. description) $
73− zipWith branch vs (ds ++ repeat mempty)
141+-- zipWith branch vs (ds ++ repeat mempty)
74− where
142+-- where
75− branch v = Branch (bname _prefix v) v
143+-- branch v = Branch (bname _prefix v) v
76−
144+
77− Obj i rs -> fmap Just $
145+-- Obj i rs -> fmap Just $
78− prod _ident _prefix i _deriving
146+-- prod _ident _prefix i _deriving
79− =<< traverse solve rs
147+-- =<< traverse solve rs
80−
148+
81− prod :: Id -> Pre -> Info -> [Derive] -> Map Local Solved -> AST Data
149+-- prod :: Id -> Pre -> Info -> [Derive] -> Map Local Solved -> AST Data
82− prod k p i ds ts = Prod (dname k) (i ^. description)
150+-- prod k p i ds ts = Prod (dname k) (i ^. description)
83− <$> pp Indent (objDecl k p ds ts)
151+-- <$> pp Indent (objDecl k p ds ts)
84− <*> ctor
152+-- <*> ctor
85− <*> traverse lens (Map.toList ts)
153+-- <*> traverse lens (Map.toList ts)
86− <*> traverse (pp Print) (jsonDecls k p ts)
154+-- <*> traverse (pp Print) (jsonDecls k p ts)
87− where
155+-- where
88− ctor = Fun' (cname k) (Just help)
156+-- ctor = Fun' (cname k) (Just help)
89− <$> (pp None (ctorSig k ts) <&> comments ts)
157+-- <$> (pp None (ctorSig k ts) <&> comments ts)
90− <*> pp Indent (ctorDecl k p ts)
158+-- <*> pp Indent (ctorDecl k p ts)
91−
159+
92− lens (l, v) = Fun' (lname p l) (v ^. description)
160+-- lens (l, v) = Fun' (lname p l) (v ^. description)
93− <$> pp None (lensSig k p l v)
161+-- <$> pp None (lensSig k p l v)
94− <*> pp Print (lensDecl p l v)
162+-- <*> pp Print (lensDecl p l v)
95−
163+
96− help = rawHelpText $
164+-- help = rawHelpText $
97− sformat ("Creates a value of '" % fid %
165+-- sformat ("Creates a value of '" % fid %
98− "' with the minimum fields required to make a request.\n")
166+-- "' with the minimum fields required to make a request.\n")
99− k
167+-- k
100−
168+
101− api :: Resource Solved -> AST API
169+-- api :: Resource Solved -> AST API
102− api x = do
170+-- api x = do
103− as <- Map.fromList <$> top x
171+-- as <- Map.fromList <$> top x
104− API n <$> pp Print (apiAlias n (Map.keys as))
172+-- API n <$> pp Print (apiAlias n (Map.keys as))
105− <*> pure as
173+-- <*> pure as
106− <*> url
174+-- <*> url
107− where
175+-- where
108− n = name (Text.unpack (svcAbbrev svc))
176+-- n = name (Text.unpack (svcAbbrev svc))
109− un = name (Text.unpack (svcURL svc))
177+-- un = name (Text.unpack (svcURL svc))
110−
178+
111− url = Fun' un (Just (rawHelpText h))
179+-- url = Fun' un (Just (rawHelpText h))
112− <$> pp None (urlSig un)
180+-- <$> pp None (urlSig un)
113− <*> pp Print url
181+-- <*> pp Print url
114− where
182+-- where
115− url | "http://" `Text.isPrefixOf` u = urlDecl un "Http" u 80
183+-- url | "http://" `Text.isPrefixOf` u = urlDecl un "Http" u 80
116− | otherwise = urlDecl un "Https" u 443
184+-- | otherwise = urlDecl un "Https" u 443
117−
185+
118− u = _svcBaseUrl svc
186+-- u = _svcBaseUrl svc
119−
187+
120− h = sformat ("URL referring to version @" % stext %
188+-- h = sformat ("URL referring to version @" % stext %
121− "@ of the " % stext % ".")
189+-- "@ of the " % stext % ".")
122− (_svcVersion svc) (_svcTitle svc)
190+-- (_svcVersion svc) (_svcTitle svc)
123−
191+
124− top = \case
192+-- top = \case
125− Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
193+-- Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
126− Sub ms -> traverse (uncurry verb) (Map.toList ms)
194+-- Sub ms -> traverse (uncurry verb) (Map.toList ms)
127−
195+
128− sub l = \case
196+-- sub l = \case
129− Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
197+-- Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
130− Sub ms -> traverse (uncurry verb) (Map.toList ms)
198+-- Sub ms -> traverse (uncurry verb) (Map.toList ms)
131−
199+
132− verb l m = do
200+-- verb l m = do
133− let (k, i, ns) = vname (svcAbbrev svc) (_mId m)
201+-- let (k, i, ns) = vname (svcAbbrev svc) (_mId m)
134− s <- solve i
202+-- s <- solve i
135− Just d <- typ s
203+-- Just d <- typ s
136− fmap (k,) $
204+-- fmap (k,) $
137− Action k (_mId m) (actionNS ns) (_mDescription m)
205+-- Action k (_mId m) (actionNS ns) (_mDescription m)
138− <$> pp Print (verbAlias k m)
206+-- <$> pp Print (verbAlias k m)
139− <*> reset k m s d
207+-- <*> reset k m s d
140−
208+
141− reset k m s = \case
209+-- reset k m s = \case
142− d@Sum {} -> pure d
210+-- d@Sum {} -> pure d
143− Prod n' h r c ls _ ->
211+-- Prod n' h r c ls _ ->
144− Prod n' h r c ls . (:[]) <$> pp Print
212+-- Prod n' h r c ls . (:[]) <$> pp Print
145− (requestDecl (_ident s) (_prefix s) k un (fields (_schema s)) m)
213+-- (requestDecl (_ident s) (_prefix s) k un (fields (_schema s)) m)
146−
214+
147− fields = \case
215+-- fields = \case
148− Obj _ rs -> Map.keys rs
216+-- Obj _ rs -> Map.keys rs
149− _ -> mempty
217+-- _ -> mempty
150−
218+
151−solveAll :: Flattened -> AST Typed
219+-- solveAll :: Flattened -> AST Typed
152−solveAll svc = do
220+-- solveAll svc = do
153− ss <- traverse solve (_svcSchemas svc)
221+-- ss <- traverse solve (_svcSchemas svc)
154− ps <- traverse (traverse solve) (_svcParameters svc)
222+-- ps <- traverse (traverse solve) (_svcParameters svc)
155− a <- traverse solve (_svcApi svc)
223+-- a <- traverse solve (_svcApi svc)
156− pure $! svc { _svcSchemas = ss, _svcParameters = ps, _svcApi = a }
224+-- pure $! svc { _svcSchemas = ss, _svcParameters = ps, _svcApi = a }
157−
225+
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+-- data PP
226− = Indent
227+-- = Indent
227− | Print
228+-- | Print
228− | None
229+-- | None
229− deriving (Eq)
230+-- deriving (Eq)
230−
231+
231−pp :: Pretty a => PP -> a -> AST Rendered
232+-- pp :: Pretty a => PP -> a -> AST Rendered
232−pp i x
233+-- pp i x
233− | i == Indent = result (reformat johanTibell Nothing p)
234+-- | i == Indent = result (reformat johanTibell Nothing p)
234− | otherwise = pure p
235+-- | otherwise = pure p
235− where
236+-- where
236− result = hoistEither . bimap e Build.toLazyText
237+-- result = hoistEither . bimap e Build.toLazyText
237−
238+
238− e = flip mappend (", when formatting: " <> p) . LText.pack
239+-- e = flip mappend (", when formatting: " <> p) . LText.pack
239−
240+
240− p = LText.dropWhile isSpace
241+-- p = LText.dropWhile isSpace
241− . LText.pack
242+-- . LText.pack
242− $ prettyPrintStyleMode s m x
243+-- $ prettyPrintStyleMode s m x
243−
244+
244− s = style
245+-- s = style
245− { mode = PageMode
246+-- { mode = PageMode
246− , lineLength = 80
247+-- , lineLength = 80
247− , ribbonsPerLine = 1.5
248+-- , ribbonsPerLine = 1.5
248− }
249+-- }
249−
250+
250− m | i == Print = defaultMode
251+-- m | i == Print = defaultMode
251− | i == Indent = defaultMode
252+-- | i == Indent = defaultMode
252− | otherwise = defaultMode
253+-- | otherwise = defaultMode
253− { layout = PPNoLayout
254+-- { layout = PPNoLayout
254− , spacing = False
255+-- , spacing = False
255− }
256+-- }
256−
257+
257−-- FIXME: dirty hack to render smart ctor parameter comments.
258+-- -- FIXME: dirty hack to render smart ctor parameter comments.
258−comments :: Map Local Solved -> Rendered -> Rendered
259+-- comments :: Map Local Solved -> Rendered -> Rendered
259−comments (Map.toList -> rs) =
260+-- comments (Map.toList -> rs) =
260− LText.replace " :: " "\n :: "
261+-- LText.replace " :: " "\n :: "
261− . LText.intercalate "\n -> "
262+-- . LText.intercalate "\n -> "
262− . zipWith rel ps
263+-- . zipWith rel ps
263− . map LText.strip
264+-- . map LText.strip
264− . LText.splitOn "->"
265+-- . LText.splitOn "->"
265− where
266+-- where
266− ks = filter (parameter . _schema . snd) rs
267+-- ks = filter (parameter . _schema . snd) rs
267− ps = map (Just . fst) ks ++ repeat Nothing
268+-- ps = map (Just . fst) ks ++ repeat Nothing
268−
269+
269− rel Nothing t = t
270+-- rel Nothing t = t
270− rel (Just l) t = t <> " -- ^ '" <> LText.fromStrict (local l) <> "'"
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 @@
12module Gen.Orphans where
12module Gen.Orphans where
13
13
14import Data.Aeson
14import Data.Aeson
15+import Data.Aeson.Types
15import Data.Bifunctor
16import Data.Bifunctor
16import Data.Hashable
17import Data.Hashable
17import qualified Data.HashMap.Strict as Map
18import 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
42import Gen.Types
42import Gen.Types
43import Prelude hiding (sum)
43import Prelude hiding (sum)
44
44
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 ()
45+-- reserve :: Flattened -> AST ()
64−reserve svc = do
46+-- reserve svc = do
65− let bs = Set.fromList $ map (CI.mk . idToText) (_svcSchemas svc)
47+-- let bs = Set.fromList $ map (CI.mk . idToText) (_svcSchemas svc)
66− branches %= Map.insert mempty bs
48+-- branches %= Map.insert mempty bs
67
49
68schema :: Id -> AST (Schema Id)
50schema :: Id -> AST (Schema Id)
69schema k = do
51schema 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 @@
6{-# LANGUAGE ExtendedDefaultRules #-}
6{-# LANGUAGE ExtendedDefaultRules #-}
7{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE FunctionalDependencies #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE KindSignatures #-}
11{-# LANGUAGE KindSignatures #-}
11{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE LambdaCase #-}
13+{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE OverloadedStrings #-}
14{-# LANGUAGE OverloadedStrings #-}
15+{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RecordWildCards #-}
16{-# LANGUAGE RecordWildCards #-}
14{-# LANGUAGE TemplateHaskell #-}
17{-# LANGUAGE TemplateHaskell #-}
15
18
16−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
17−
18-- Module : Gen.Types
19-- Module : Gen.Types
19-- Copyright : (c) 2015 Brendan Hay
20-- Copyright : (c) 2015 Brendan Hay
20-- License : Mozilla Public License, v. 2.0.
21-- License : Mozilla Public License, v. 2.0.
@@ -28,12 +29,19 @@ module Gen.Types
28 , module Gen.Types.Id
29 , module Gen.Types.Id
29 , module Gen.Types.Map
30 , module Gen.Types.Map
30 , module Gen.Types.NS
31 , module Gen.Types.NS
32+ , module Gen.Types.Schema
33+ , module Gen.Types.Data
31 ) where
34 ) where
32
35
33import Control.Applicative
36import Control.Applicative
34import Control.Lens hiding ((.=))
37import Control.Lens hiding ((.=))
38+import Control.Monad.Except
39+import Control.Monad.State.Strict
35−import Data.Aeson hiding (Bool, String)
40+import Data.Aeson hiding (Array, Bool, String)
41+import qualified Data.Aeson as A
36import Data.Aeson.TH
42import Data.Aeson.TH
43+import Data.CaseInsensitive (CI)
44+import qualified Data.CaseInsensitive as CI
37import Data.Char
45import Data.Char
38import Data.Function (on)
46import Data.Function (on)
39import qualified Data.HashMap.Strict as Map
47import qualified Data.HashMap.Strict as Map
@@ -54,37 +62,23 @@ import qualified Filesystem.Path.CurrentOS as Path
54import Formatting
62import Formatting
55import Gen.Orphans ()
63import Gen.Orphans ()
56import Gen.Text
64import Gen.Text
65+import Gen.TH
66+import Gen.Types.Data
57import Gen.Types.Help
67import Gen.Types.Help
58import Gen.Types.Id
68import Gen.Types.Id
59import Gen.Types.Map
69import Gen.Types.Map
60import Gen.Types.NS
70import Gen.Types.NS
71+import Gen.Types.Schema
61import GHC.Generics
72import GHC.Generics
62import GHC.TypeLits
73import GHC.TypeLits
63import Language.Haskell.Exts (Name)
74import Language.Haskell.Exts (Name)
64import Language.Haskell.Exts.Pretty (Pretty, prettyPrint)
75import Language.Haskell.Exts.Pretty (Pretty, prettyPrint)
76+import Prelude hiding (Enum)
65import Text.EDE (Template)
77import Text.EDE (Template)
66
78
67−default (Text)
68−
69−newtype Fix f = Fix (f (Fix f))
70−
71−type Set = Set.HashSet
79+type Set = Set.HashSet
72−type Error = LText.Text
80+type Error = LText.Text
73−type Rendered = LText.Text
74−type Path = Path.FilePath
81+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− }
88
82
89newtype Version (v :: Symbol) = Version Text
83newtype Version (v :: Symbol) = Version Text
90 deriving (Eq, Show)
84 deriving (Eq, Show)
@@ -105,193 +99,118 @@ data Versions = Versions
105 , _coreVersion :: CoreVer
99 , _coreVersion :: CoreVer
106 } deriving (Show)
100 } deriving (Show)
107
101
102+makeClassy ''Versions
103+
108−-- FIXME: need a more comprehensive 'vm_alpha' vs 'vm1.1' etc check.
104+-- FIXME: need a more comprehensive 'vm_alpha' vs 'vm1.1' version check.
109−data Spec = Spec
105+data Model = Model
110− { _specName :: Text
106+ { modelName :: Text
111− , _specPrefix :: Text
107+ , modelPrefix :: Text
112− , _specVersion :: Text
108+ , modelVersion :: Text
113− , _specPath :: Path
109+ , modelPath :: Path
114 }
110 }
115
111
116−instance Eq Spec where
112+instance Eq Model where
117− (==) = on (==) _specPrefix
113+ (==) = on (==) modelPrefix
118
114
119−instance Ord Spec where
115+instance Ord Model where
120 compare a b =
116 compare a b =
121− on compare _specPrefix a b
117+ on compare modelPrefix a b
122− <> on compare (Down . _specVersion) a b
118+ <> on compare (Down . modelVersion) a b
123
119
124−specFromPath :: Path -> Spec
120+modelFromPath :: Path -> Model
125−specFromPath x = Spec n p v x
121+modelFromPath x = Model n p v x
126 where
122 where
127− -- FIXME:
128− n = Text.init
123+ n = Text.init
129− . Text.intercalate "/"
124+ . Text.intercalate "/"
130− . drop 1
125+ . drop 1
131− . dropWhile (/= "model")
126+ . dropWhile (/= "model")
132− $ Text.split (== '/') p
127+ $ Text.split (== '/') p
133
128
134− p = toTextIgnore (Path.parent (Path.parent x))
129+ p = toTextIgnore (Path.parent (Path.parent x))
135− v = toTextIgnore (Path.dirname x)
130+ v = toTextIgnore (Path.dirname x)
136
131
137−data Protocol = REST
132+data Templates = Templates
138− deriving (Eq, Show)
133+ { cabalTemplate :: Template
134+ , tocTemplate :: Template
135+ , readmeTemplate :: Template
136+ , typesTemplate :: Template
137+ , prodTemplate :: Template
138+ , sumTemplate :: Template
139+ , actionTemplate :: Template
140+ }
139
141
140−instance FromJSON Protocol where
142+tocImports, typeImports, prodImports, sumImports, actionImports
141− parseJSON = withText "protocol" $ \case
143+ :: Service a -> [NS]
142− "rest" -> pure REST
144+tocImports _ = [preludeNS]
143− e -> fail $ "Unable to parse protocol from " ++ Text.unpack e
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
144
155
145−instance ToJSON Protocol where
156+preludeNS :: NS
146− toJSON = toJSON . map toLower . show
157+preludeNS = "Network.Google.Prelude"
147
158
148−data Location
159+-- actionNS :: [Text] -> NS
149− = Query
160+-- actionNS = mappend (NS ["Network", "Google", "API"]) . NS
150− | Path
151− deriving (Eq, Show)
152
161
153−deriveJSON (js "") ''Location
162+-- exposedModules :: Service s p API -> [NS]
154−
163+-- exposedModules s = sort (tocNS s : typesNS s : map _actNS (svcActions s))
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)
190
164
191−instance FromJSON Lit where
165+-- otherModules :: Service s p r -> [NS]
192− parseJSON = withObject "literal" $ \o -> do
166+-- otherModules s = sort [prodNS s, sumNS s]
193− n <- num =<< (o .:? "minimum" .!= "0")
167+
194− (o .: "format" <|> o .: "type") >>= \case
168+toTextIgnore :: Path -> Text
195− -- Types
169+toTextIgnore = either id id . Path.toText
196− "string" -> pure Text
170+
197− "boolean" -> pure Bool
171+data Library = Library
198− -- Formats
172+ { _lVersions :: Versions
199− "float" -> pure Float
173+ , _lService :: Service Global
200− "double" -> pure Double
174+ -- , _lMethods ::
201− "byte" -> pure (nat n Byte)
175+ -- , _lResources :: []
202− "uint32" -> pure (nat n UInt32)
176+ -- , _lSchemas :: [Data]
203− "uint64" -> pure (nat n UInt64)
177+ }
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)
244
178
245− enm i o = Enum i <$> o .: "enum" <*> o .: "enumDescriptions"
179+makeLenses ''Library
246− ref i o = Ref i <$> o .: "$ref"
247
180
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)
249
210
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 })
292
211
293data TType
212data TType
294− = TType Id
213+ = TType Global
295 | TLit Lit
214 | TLit Lit
296 | TMaybe TType
215 | TMaybe TType
297 | TEither TType TType
216 | TEither TType TType
@@ -314,9 +233,9 @@ data Derive
314 deriving (Eq, Show)
233 deriving (Eq, Show)
315
234
316data Solved = Solved
235data Solved = Solved
317− { _ident :: Id
236+ { _ident :: Global
318− , _prefix :: Pre
237+ , _prefix :: Prefix
319− , _schema :: Schema Id
238+ , _schema :: Schema Global
320 , _type :: TType
239 , _type :: TType
321 , _deriving :: [Derive]
240 , _deriving :: [Derive]
322 }
241 }
@@ -329,254 +248,24 @@ instance HasInfo Solved where
329monoid :: Solved -> Bool
248monoid :: Solved -> Bool
330monoid = elem DMonoid . _deriving
249monoid = elem DMonoid . _deriving
331
250
332−data Syn a = Syn { syntax :: a }
251+type Seen = Map (CI Text) {- Prefix -} (Set (CI Text)) {- Inhabitants -}
333−
334−instance Pretty a => ToJSON (Syn a) where
335− toJSON = toJSON . prettyPrint . syntax
336
252
337−data Fun = Fun' Name (Maybe Help) Rendered Rendered
253+data Memo = Memo
338−
254+ { _context :: Service (Fix Schema)
339−instance ToJSON Fun where
255+ , _typed :: Map Global TType
340− toJSON (Fun' n h s d) = object
256+ , _derived :: Map Global [Derive]
341− [ "name" .= Syn n
257+ , _schemas :: Map Global (Schema Global)
342− , "help" .= h
258+ , _prefixed :: Map Global Prefix
343− , "sig" .= s
259+ , _branches :: Seen
344− , "decl" .= d
260+ , _fields :: Seen
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
391 }
261 }
392
262
393−actionTypeName :: Action -> Name
263+initial :: Service (Fix Schema) -> Memo
394−actionTypeName = dataName . _actData
264+initial s = Memo s mempty mempty mempty mempty mempty mempty
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− ]
405
265
406−data API = API
266+makeLenses ''Memo
407− { _apiName :: Name
408− , _apiDecl :: Rendered
409− , _apiActions :: Map Name Action
410− , _apiURL :: Fun
411− }
412
267
413−instance ToJSON API where
268+instance HasService Memo (Fix Schema) where
414− toJSON API {..} = object
269+ service = context
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− ]
511
270
512−type Parsed = Service (Map Id (Fix Schema))
271+type AST = ExceptT Error (State Memo)
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− }
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 @@
11-- Stability : provisional
11-- Stability : provisional
12-- Portability : non-portable (GHC extensions)
12-- Portability : non-portable (GHC extensions)
13
13
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
15
22
16import Control.Applicative
23import Control.Applicative
17import Control.Lens hiding (pre, (.=))
24import Control.Lens hiding (pre, (.=))
@@ -36,6 +43,7 @@ import qualified Data.Text.Lazy as LText
36import qualified Data.Text.Lazy.Builder as Build
43import qualified Data.Text.Lazy.Builder as Build
37import Data.Text.Manipulate
44import Data.Text.Manipulate
38import Formatting
45import Formatting
46+import Gen.Orphans ()
39import Gen.Text
47import Gen.Text
40import Gen.Types.Map
48import Gen.Types.Map
41import GHC.Generics
49import GHC.Generics
@@ -43,47 +51,49 @@ import Language.Haskell.Exts.Build
43import Language.Haskell.Exts.Pretty (prettyPrint)
51import Language.Haskell.Exts.Pretty (prettyPrint)
44import Language.Haskell.Exts.Syntax (Name)
52import Language.Haskell.Exts.Syntax (Name)
45
53
46−vname :: Text -> Text -> (Name, Id, [Text])
54+-- vname :: Text -> Text -> (Name, Id, [Text])
47−vname abrv r = (dname (g (n <> "API")), g (n <> "'"), ns)
55+-- vname abrv r = (dname (g (n <> "API")), g (n <> "'"), ns)
48− where
56+-- where
49− g = Free . Global
57+-- g = Free . Global
50− n = mconcat (drop 1 ns)
58+-- n = mconcat (drop 1 ns)
51
59
52− ns | CI.mk e == CI.mk x = e:xs
60+-- ns | CI.mk e == CI.mk x = e:xs
53− | otherwise = x:xs
61+-- | otherwise = x:xs
54− where
62+-- where
55− e = Text.replace "." "" abrv
63+-- e = Text.replace "." "" abrv
56− x:xs = map (upperAcronym . upperHead) $ Text.split (== '.') r
64+-- x:xs = map (upperAcronym . upperHead) $ Text.split (== '.') r
57
65
58−dname, cname :: Id -> Name
66+-- dname, cname :: Id -> Name
59−dname = name . Text.unpack . upperHead . idToText
67+-- dname = name . Text.unpack . upperHead . idToText
60−cname = name . Text.unpack . renameReserved . lowerHead . idToText
68+-- cname = name . Text.unpack . renameReserved . lowerHead . idToText
61
69
62−bname :: Pre -> Text -> Name
70+-- bname :: Pre -> Text -> Name
63−bname (Pre p) = name
71+-- bname (Pre p) = name
64− . Text.unpack
72+-- . Text.unpack
65− . mappend (Text.toUpper p)
73+-- . mappend (Text.toUpper p)
66− . renameBranch
74+-- . renameBranch
67
75
68−fname, lname, pname :: Pre -> Local -> Name
76+-- fname, lname, pname :: Pre -> Local -> Name
69−fname = pre (Text.cons '_' . renameField)
77+-- fname = pre (Text.cons '_' . renameField)
70−lname = pre renameField
78+-- lname = pre renameField
71−pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)
79+-- pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)
72
80
73−apretty :: Local -> Local -> Text
81+-- apretty :: Local -> Local -> Text
74−apretty p l = upperHead (local l) <> " " <> upperHead (local p)
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)
75
89
76−pre :: (Text -> Text) -> Pre -> Local -> Name
77−pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local
78
90
79newtype Global = Global { global :: Text }
91newtype Global = Global { global :: Text }
80 deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)
92 deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)
81
93
82−instance FromJSON a => FromJSON (Map Global a) where
94+instance TextKey Global where
83− parseJSON = fmap (fromMap Global) . parseJSON
95+ toKey = Global
84−
96+ fromKey = global
85−instance ToJSON a => ToJSON (Map Global a) where
86− toJSON = toJSON . toMap global
87
97
88gid :: Format a (Global -> a)
98gid :: Format a (Global -> a)
89gid = later (Build.fromText . global)
99gid = later (Build.fromText . global)
@@ -91,60 +101,12 @@ gid = later (Build.fromText . global)
91newtype Local = Local { local :: Text }
101newtype Local = Local { local :: Text }
92 deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)
102 deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)
93
103
94−instance FromJSON a => FromJSON (Map Local a) where
104+instance TextKey Local where
95− parseJSON = fmap (fromMap Local) . parseJSON
105+ toKey = Local
96−
106+ fromKey = local
97−instance ToJSON a => ToJSON (Map Local a) where
98− toJSON = toJSON . toMap local
99
107
100lid :: Format a (Local -> a)
108lid :: Format a (Local -> a)
101lid = later (Build.fromText . local)
109lid = later (Build.fromText . local)
102
110
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
111+reference :: Global -> Local -> Global
123−mkId g = \case
112+reference (Global g) (Local l) = Global (g <> "." <> l)
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
gen/src/Gen/Types/Map.hs+20−1
@@ -1,4 +1,7 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+
3+
1−-- Module : Gen.Types.Map
4+ -- Module : Gen.Types.Map
2-- Copyright : (c) 2013-2015 Brendan Hay
5-- Copyright : (c) 2013-2015 Brendan Hay
3-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
4-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
@@ -11,9 +14,14 @@
11module Gen.Types.Map where
14module Gen.Types.Map where
12
15
13import Control.Lens
16import Control.Lens
17+import Control.Monad
18+import Data.Aeson
19+import Data.Aeson.Types
20+import Data.Bifunctor
14import Data.Hashable
21import Data.Hashable
15import qualified Data.HashMap.Strict as Map
22import qualified Data.HashMap.Strict as Map
16import Data.Maybe
23import Data.Maybe
24+import Data.Text (Text)
17
25
18type Map = Map.HashMap
26type Map = Map.HashMap
19
27
@@ -29,3 +37,14 @@ kvTraverseMaybe :: (Applicative f, Eq k, Hashable k)
29 -> f (Map k b)
37 -> f (Map k b)
30kvTraverseMaybe f = fmap (Map.map fromJust . Map.filter isJust)
38kvTraverseMaybe f = fmap (Map.map fromJust . Map.filter isJust)
31 . Map.traverseWithKey f
39 . 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 @@
7-- Stability : provisional
7-- Stability : provisional
8-- Portability : non-portable (GHC extensions)
8-- Portability : non-portable (GHC extensions)
9
9
10−module Gen.Types.NS where
10+module Gen.Types.NS
11+ ( NS
12+ , mkNS
13+ ) where
11
14
12import Data.Aeson
15import Data.Aeson
13import Data.Aeson.Types
16import Data.Aeson.Types
@@ -48,19 +51,3 @@ instance FromJSON NS where
48
51
49instance ToJSON NS where
52instance ToJSON NS where
50 toJSON (NS xs) = toJSON (Text.intercalate "." xs)
53 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+