git.iko.soy/gogol
on develop help sign in
Rendering verbosity
commit4278cc5102d45fad8583d33bc776fec7a20f3395 authorBrendan Hay <brendan.g.hay@gmail.com> dateTue 22 Sep 2015, 14:47 (11 years ago) parentb6a29af
4 files changed+127−28
compare with develop
unifiedsplit
gen/gozen-gen.cabal+7−4 gen/src/Gen/Types.hs+37−11 gen/src/Gen/Types/NS.hs+47 gen/src/Main.hs+36−13
gen/gozen-gen.cabal+7−4
@@ -21,10 +21,11 @@ executable gozen-gen
2121 main-is: Main.hs
2222
2323 other-modules:
24− Gen.IO
25− , Gen.Types
26− , Gen.Formatting
24+ Gen.Formatting
25+ , Gen.IO
2726 , Gen.JSON
27+ , Gen.Types
28+ , Gen.Types.NS
2829
2930 ghc-options: -Wall -threaded
3031
@@ -43,4 +44,6 @@ executable gozen-gen
4344 , formatting
4445 , unordered-containers
4546 , attoparsec
46− , bifunctors
47+ , bifunctors
48+ , semigroups
49+ , text-manipulate
gen/src/Gen/Types.hs+37−11
@@ -13,20 +13,25 @@
1313
1414module Gen.Types where
1515
16+--import Control.Lens
1617import Data.Aeson
1718import Data.Aeson.TH
1819import qualified Data.Attoparsec.Text as A
1920import Data.Char
2021import Data.Function (on)
2122import qualified Data.HashMap.Strict as Map
22−import Data.List (nub, sort)
23−import Data.Monoid
23+import Data.List (groupBy, nub, sort)
24+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
25+import qualified Data.List.NonEmpty as NE
2426import Data.Ord
27+import Data.Semigroup
2528import Data.Text (Text)
2629import qualified Data.Text as Text
2730import qualified Data.Text.Lazy as LText
31+import Data.Text.Manipulate
2832import qualified Filesystem.Path.CurrentOS as Path
2933import Gen.JSON
34+import Gen.Types.NS
3035import GHC.TypeLits
3136import Text.EDE (Template)
3237
@@ -58,6 +63,8 @@ data Versions = Versions
5863 , _coreVersion :: CoreVer
5964 } deriving (Show)
6065
66+-- makeClassy ''Versions
67+
6168-- FIXME: need a more comprehensive 'vm_alpha' vs 'vm1.1' etc check.
6269data Spec = Spec
6370 { _specName :: Text
@@ -96,20 +103,15 @@ instance FromJSON Protocol where
96103 e -> fail $ "Unable to parse protocol from " ++ Text.unpack e
97104
98105data Service = Service
99− { _svcKind :: Text
100− , _svcEtag :: Text
101− , _svcDiscoveryVersion :: Text
102− , _svcId :: Text
106+ { _svcTitle :: Text
103107 , _svcName :: Text
104108 , _svcCanonicalName :: Maybe Text
105− , _svcTitle :: Text
106− , _svcVersion :: Text
107− , _svcRevision :: Maybe Text
108109 , _svcDescription :: Text
109− , _svcOwnerDomain :: Text
110+ , _svcRevision :: Maybe Text
111+ , _svcVersion :: Text
110112 , _svcOwnerName :: Text
113+ , _svcOwnerDomain :: Text
111114 , _svcPackagePath :: Maybe Text
112− , _svcIcons :: Object
113115 , _svcDocumentationLink :: Text
114116 , _svcProtocol :: Protocol
115117 , _svcBaseUrl :: Text
@@ -122,3 +124,27 @@ data Service = Service
122124 } deriving (Show)
123125
124126deriveFromJSON (js "_svc") ''Service
127+
128+data Library = Library
129+ { _libName :: Text
130+ , _libTitle :: Text
131+ , _libDescriptions :: [Text]
132+ , _libNamespace :: NS
133+ , _libVersions :: Versions
134+ , _libServices :: NonEmpty Service
135+ }
136+
137+mergeLibraries :: Versions -> [Service] -> [Library]
138+mergeLibraries v = map go . groupBy (on (==) _svcName)
139+ where
140+ go [x] = mk x
141+ go (x:xs) = (mk x) { _libServices = x :| xs }
142+
143+ mk x = Library
144+ { _libName = "gozen-" <> Text.toLower (_svcName x)
145+ , _libTitle = _svcTitle x
146+ , _libDescriptions = []
147+ , _libNamespace = "Network.Google" <> mkNS (toPascal (_svcName x))
148+ , _libVersions = v
149+ , _libServices = x :| []
150+ }
gen/src/Gen/Types/NS.hsnew file+47
@@ -0,0 +1,47 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- Module : Gen.Types.NS
4+-- Copyright : (c) 2015 Brendan Hay
5+-- License : Mozilla Public License, v. 2.0.
6+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
7+-- Stability : provisional
8+-- Portability : non-portable (GHC extensions)
9+
10+module Gen.Types.NS where
11+
12+import Data.Aeson
13+import Data.Monoid
14+import Data.Semigroup
15+import Data.String
16+import Data.Text (Text)
17+import qualified Data.Text as Text
18+import qualified Filesystem.Path.CurrentOS as Path
19+
20+newtype NS = NS [Text]
21+ deriving (Eq, Ord, Show)
22+
23+mkNS :: Text -> NS
24+mkNS = NS . Text.splitOn "."
25+
26+nsToPath :: NS -> Path.FilePath
27+nsToPath (NS xs) = Path.fromText (Text.intercalate "/" xs) Path.<.> "hs"
28+
29+instance IsString NS where
30+ fromString "" = mempty
31+ fromString s = mkNS (fromString s)
32+
33+instance Monoid NS where
34+ mempty = NS []
35+ mappend (NS xs) (NS ys)
36+ | null xs = NS ys
37+ | null ys = NS xs
38+ | otherwise = NS (mappend xs ys)
39+
40+instance Semigroup NS where
41+ (<>) = mappend
42+
43+instance FromJSON NS where
44+ parseJSON = withText "namespace" (pure . mkNS)
45+
46+instance ToJSON NS where
47+ toJSON (NS xs) = toJSON (Text.intercalate "." xs)
gen/src/Main.hs+36−13
@@ -18,6 +18,7 @@ import Control.Lens
1818import Control.Monad.State
1919import Data.List (nub, sort)
2020import Data.String
21+import Data.Text (Text)
2122import qualified Data.Text as Text
2223import qualified Filesystem as FS
2324import Filesystem.Path.CurrentOS
@@ -111,6 +112,7 @@ main = do
111112 Opt{..} <- customExecParser (prefs showHelpOnError) options >>= validate
112113
113114 let ss = nub . sort $ map specFromPath _optModels
115+ i = length ss
114116
115117 run $ do
116118 title "Initialising..." <* done
@@ -127,20 +129,28 @@ main = do
127129 <* lift done
128130
129131 say ("Found " % int % " model specifications.") (length _optModels)
130− say ("Selected " % int % " newest models.") (length ss)
131−
132− forM_ (zip [1..] ss) $ \(j, Spec{..}) -> do
133− title ("[" % int % "/" % int % "] model:" % stext)
134− (j :: Int) (length ss) _specName
132+ say ("Selected " % int % " newest models.") i
135133
134+ svcs <- counter "model" ss $ \Spec{..} -> do
136135 say ("Using version " % stext) _specVersion
137136
138− -- cfg <- JS.required (_optConfigs </> (m ^. configFile))
139− -- >>= hoistEither . JS.parse
137+ s <- readBSFile _specPath >>= JS.decode
138+
139+ say ("Successfully parsed '" % stext % "' API definition.")
140+ (_svcTitle s)
141+
142+ done
143+
144+ return s
140145
141− svc <- readBSFile _specPath >>= JS.decode
146+ let libs = mergeLibraries _optVersions svcs
142147
143− say ("Service: " % string) (show (svc :: Service))
148+ _ <- counter "library" libs $ \l -> do
149+ say ("Creating " % stext % " package.") (_libTitle l)
150+
151+ done
152+
153+-- say ("Service: " % string) (
144154
145155 -- api <- sequence
146156 -- [ JS.optional (_optAnnexes </> (m ^. annexFile))
@@ -150,9 +160,6 @@ main = do
150160 -- , pure r
151161 -- ] >>= hoistEither . JS.parse . JS.merge
152162
153− -- say ("Successfully parsed '" % stext % "' API definition")
154− -- (api ^. serviceFullName)
155−
156163 -- lib <- hoistEither (AST.rewrite _optVersions cfg api)
157164
158165 -- dir <- hoistEither (Tree.populate _optOutput tmpl lib)
@@ -166,4 +173,20 @@ main = do
166173
167174 -- done
168175
169− -- title ("Successfully processed " % int % " models.") i
176+ title ("Successfully processed " % int % " models.") i
177+ title ("Successfully created " % int % " library packages.") (length libs)
178+
179+class HasName a where getName :: a -> Text
180+instance HasName Spec where getName = _specName
181+instance HasName Library where getName = _libName
182+
183+-- counter :: (MonadIO n, m ~ ExceptT n Error, HasName a)
184+-- => [a]
185+-- -> (a -> m b)
186+-- -> m [b]
187+counter k xs f = forM (zip [1..] xs) $ \(n, x) -> do
188+ title ("[" % int % "/" % int % "] " % stext % ":" % stext)
189+ (n :: Int) i k (getName x)
190+ f x
191+ where
192+ i = length xs