git.iko.soy/gogol
on develop help sign in
Rendering basic toc + types modules + library skeleton
53af420Brendan Hay
gen/src/Gen/IO.hs+27−29
compare with develop
unifiedsplit
@@ -24,6 +24,7 @@ import qualified Filesystem as FS
24import Filesystem.Path.CurrentOS
24import Filesystem.Path.CurrentOS
25import Gen.Formatting
25import Gen.Formatting
26import Gen.Types
26import Gen.Types
27+import System.IO
27import qualified Text.EDE as EDE
28import qualified Text.EDE as EDE
28
29
29run :: ExceptT Error IO a -> IO a
30run :: ExceptT Error IO a -> IO a
@@ -44,9 +45,6 @@ done = title ""
44isFile :: MonadIO m => Path -> ExceptT Error m Bool
45isFile :: MonadIO m => Path -> ExceptT Error m Bool
45isFile = io . FS.isFile
46isFile = io . FS.isFile
46
47
47−-- listDir :: MonadIO m => Path -> ExceptT Error m [Path]
48−-- listDir = io . FS.listDirectory
49−
50readBSFile :: MonadIO m => Path -> ExceptT Error m ByteString
48readBSFile :: MonadIO m => Path -> ExceptT Error m ByteString
51readBSFile f = do
49readBSFile f = do
52 p <- isFile f
50 p <- isFile f
@@ -54,33 +52,33 @@ readBSFile f = do
54 then say ("Reading " % path) f >> io (FS.readFile f)
52 then say ("Reading " % path) f >> io (FS.readFile f)
55 else failure ("Missing " % path) f
53 else failure ("Missing " % path) f
56
54
57−-- writeLTFile :: MonadIO m => Path -> LText.Text -> ExceptT Error m ()
55+writeLTFile :: MonadIO m => Path -> LText.Text -> ExceptT Error m ()
58−-- writeLTFile f t = do
56+writeLTFile f t = do
59−-- say ("Writing " % path) f
57+ say ("Writing " % path) f
60−-- io . FS.withFile f FS.WriteMode $ \h -> do
58+ io . FS.withFile f FS.WriteMode $ \h -> do
61−-- hSetEncoding h utf8
59+ hSetEncoding h utf8
62−-- LText.hPutStr h t
60+ LText.hPutStr h t
63−
64−-- touchFile :: MonadIO m => Path -> ExceptT Error m ()
65−-- touchFile f = do
66−-- p <- isFile f
67−-- unless p $
68−-- writeLTFile f mempty
69−
70−-- createDir :: MonadIO m => Path -> ExceptT Error m ()
71−-- createDir d = do
72−-- p <- io (FS.isDirectory d)
73−-- unless p $ do
74−-- say ("Creating " % path) d
75−-- io (FS.createTree d)
76
61
62+touchFile :: MonadIO m => Path -> ExceptT Error m ()
63+touchFile f = do
64+ p <- isFile f
65+ unless p $
66+ writeLTFile f mempty
67+
68+createDir :: MonadIO m => Path -> ExceptT Error m ()
69+createDir d = do
70+ p <- io (FS.isDirectory d)
71+ unless p $ do
72+ say ("Creating " % path) d
73+ io (FS.createTree d)
74+
77−-- copyDir :: MonadIO m => Path -> Path -> ExceptT Error m ()
75+copyDir :: MonadIO m => Path -> Path -> ExceptT Error m ()
78−-- copyDir src dst = io (FS.listDirectory src >>= mapM_ copy)
76+copyDir src dst = io (FS.listDirectory src >>= mapM_ copy)
79−-- where
77+ where
80−-- copy f = do
78+ copy f = do
81−-- let p = dst </> filename f
79+ let p = dst </> filename f
82−-- fprint (" -> Copying " % path % " to " % path % "\n") f (directory p)
80+ fprint (" -> Copying " % path % " to " % path % "\n") f (directory p)
83−-- FS.copyFile f p
81+ FS.copyFile f p
84
82
85readTemplate :: MonadIO m
83readTemplate :: MonadIO m
86 => Path
84 => Path
gen/src/Gen/JSON.hs+29−39
@@ -17,47 +17,37 @@ import Data.Aeson.Types
17import Data.Bifunctor
17import Data.Bifunctor
18import Data.ByteString (ByteString)
18import Data.ByteString (ByteString)
19import qualified Data.ByteString.Lazy as LBS
19import qualified Data.ByteString.Lazy as LBS
20−import Data.Char
21import qualified Data.HashMap.Strict as Map
20import qualified Data.HashMap.Strict as Map
22import Data.List
21import Data.List
23import qualified Data.Text.Lazy as LText
22import qualified Data.Text.Lazy as LText
23+import Gen.Formatting
24+import Gen.IO
25+import Gen.Types
24import qualified Text.EDE as EDE
26import qualified Text.EDE as EDE
25
27
26−decode :: (Monad m, FromJSON a) => ByteString -> ExceptT LText.Text m a
27−decode = hoistEither . first LText.pack . eitherDecode' . LBS.fromStrict
28−
29−js :: String -> Options
30−js pre = defaultOptions
31− { constructorTagModifier = map toLower
32− , fieldLabelModifier = \s ->
33− let x:xs = drop (length pre) s
34− in toLower x : xs
35− }
36−
37−-- optional :: MonadIO m => Path -> ExceptT Error m Object
38−-- optional f = readBSFile f `catchError` const (return "{}")
39−-- >>= hoistEither . decode
40−
41−-- objectErr :: ToJSON a => String -> a -> Either Error Object
28+objectErr :: ToJSON a => String -> a -> Either Error Object
42−-- objectErr n =
29+objectErr n =
43−-- note (format ("Failed to extract JSON object from value " % string) n)
30+ note (format ("Failed to extract JSON object from value " % string) n)
44−-- . EDE.fromValue
31+ . EDE.fromValue
45−-- . toJSON
32+ . toJSON
46−
33+
47−-- decode :: FromJByteString -> Either Error a
34+load :: MonadIO m => Path -> ExceptT Error m Object
35+load = readBSFile >=> hoistEither . decode
36+
37+decode :: ByteString -> Either Error Object
48−-- decode = first LText.pack . eitherDecode' . LBS.fromStrict
38+decode = first LText.pack . eitherDecode' . LBS.fromStrict
49−
39+
50−-- parse :: FromJSON a => Object -> Either Error a
40+parse :: FromJSON a => Object -> Either Error a
51−-- parse = first LText.pack . parseEither parseJSON . Object
41+parse = first LText.pack . parseEither parseJSON . Object
52−
42+
53−-- merge :: [Object] -> Object
43+merge :: [Object] -> Object
54−-- merge = foldl' go mempty
44+merge = foldl' go mempty
55−-- where
45+ where
56−-- go :: Object -> Object -> Object
46+ go :: Object -> Object -> Object
57−-- go = Map.unionWith value
47+ go = Map.unionWith value
58−
48+
59−-- value :: Value -> Value -> Value
49+ value :: Value -> Value -> Value
60−-- value l r =
50+ value l r =
61−-- case (l, r) of
51+ case (l, r) of
62−-- (Object x, Object y) -> Object (x `go` y)
52+ (Object x, Object y) -> Object (x `go` y)
63−-- (_, _) -> l
53+ (_, _) -> l
gen/src/Gen/Text.hsnew file+119
@@ -0,0 +1,119 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE TupleSections #-}
3+
4+-- Module : Gen.Text
5+-- Copyright : (c) 2013-2015 Brendan Hay
6+-- License : This Source Code Form is subject to the terms of
7+-- the Mozilla Public License, v. 2.0.
8+-- A copy of the MPL can be found in the LICENSE file or
9+-- you can obtain it at http://mozilla.org/MPL/2.0/.
10+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
11+-- Stability : provisional
12+-- Portability : non-portable (GHC extensions)
13+
14+module Gen.Text where
15+
16+import Control.Error
17+import Control.Monad
18+import Data.Bifunctor
19+import Data.Char
20+import qualified Data.Foldable as Fold
21+import qualified Data.HashSet as Set
22+import Data.Monoid
23+import Data.String
24+import Data.Text (Text)
25+import qualified Data.Text as Text
26+-- import Data.Text.ICU (Regex)
27+-- import Data.Text.ICU.Replace (Replace)
28+-- import qualified Data.Text.ICU.Replace as RE
29+import Data.Text.Manipulate
30+-- import Text.Parsec.Language (haskellDef)
31+-- import Text.Parsec.Token (reservedNames)
32+
33+-- asText :: (Text -> Text) -> String -> String
34+-- asText f = Text.unpack . f . Text.pack
35+
36+-- dropLower :: Text -> Text
37+-- dropLower = Text.dropWhile (not . isUpper)
38+
39+-- safeHead :: Text -> Maybe Text
40+-- safeHead = fmap (Text.singleton . fst) . Text.uncons
41+
42+-- stripLens :: Text -> Text
43+-- stripLens t
44+-- | "_" `Text.isPrefixOf` t = lowerHead (dropLower t)
45+-- | otherwise = t
46+
47+stripPrefix :: Text -> Text -> Text
48+stripPrefix p t = Text.strip . fromMaybe t $ p `Text.stripPrefix` t
49+
50+stripSuffix :: Text -> Text -> Text
51+stripSuffix s t = Text.strip . fromMaybe t $ s `Text.stripSuffix` t
52+
53+renameLibrary :: Text -> Text
54+renameLibrary =
55+ mappend "gozen-"
56+ . Text.toLower
57+
58+renameTitle :: Text -> Text
59+renameTitle =
60+ mappend "Google "
61+ . flip mappend " API"
62+ . stripPrefix "Google "
63+ . stripSuffix " API"
64+
65+renameAbbrev :: Text -> Text
66+renameAbbrev = mconcat
67+ . Text.split isSpace
68+ . stripPrefix "Google "
69+ . stripSuffix " API"
70+
71+-- renameReserved :: Text -> Text
72+-- renameReserved x
73+-- | x `Set.member` xs = x <> "'"
74+-- | otherwise = x
75+-- where
76+-- xs = Set.fromList $
77+-- [ "head"
78+-- , "tail"
79+-- , "delete"
80+-- , "filter"
81+-- , "True"
82+-- , "False"
83+-- , "map"
84+-- , "object"
85+-- , "get"
86+-- , "group"
87+-- , "GT"
88+-- , "LT"
89+-- , "EQ"
90+-- , "Error"
91+-- ] ++ map Text.pack (reservedNames haskellDef)
92+
93+-- camelAcronym :: Text -> Text
94+-- camelAcronym x = replaceAll x xs
95+-- where
96+-- xs = map (bimap fromString fromString) acronyms
97+
98+-- lowerFirstAcronym :: Text -> Text
99+-- lowerFirstAcronym x = replaceAll x xs
100+-- where
101+-- xs = map (bimap (fromString . ('^':)) (fromString . f)) acronyms
102+
103+-- f (c:cs) = toLower c : cs
104+-- f [] = []
105+
106+-- replaceAll :: Text -> [(Regex, Replace)] -> Text
107+-- replaceAll = Fold.foldl' (flip (uncurry RE.replaceAll))
108+
109+-- upperAcronym :: Text -> Text
110+-- upperAcronym x = Fold.foldl' (flip (uncurry RE.replaceAll)) x xs
111+-- where
112+-- xs :: [(Regex, Replace)]
113+-- xs = [ ("Acl", "ACL")
114+-- ]
115+
116+-- acronyms :: [(String, String)]
117+-- acronyms =
118+-- [ ("ACL", "Acl")
119+-- ]
gen/src/Gen/Tree.hsnew file+156
@@ -0,0 +1,156 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE ViewPatterns #-}
10+
11+-- Module : Gen.Tree
12+-- Copyright : (c) 2015 Brendan Hay
13+-- License : Mozilla Public License, v. 2.0.
14+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
15+-- Stability : provisional
16+-- Portability : non-portable (GHC extensions)
17+
18+module Gen.Tree
19+ ( root
20+ , fold
21+ , populate
22+ ) where
23+
24+import Control.Error
25+import Control.Lens (each, (^.), (^..))
26+import Control.Monad
27+import Control.Monad.Except
28+import Data.Aeson hiding (json)
29+import Data.Bifunctor
30+import Data.Functor.Identity
31+import qualified Data.HashMap.Strict as Map
32+import qualified Data.List.NonEmpty as NE
33+import Data.Monoid
34+import Data.Text (Text)
35+import qualified Data.Text as Text
36+import qualified Data.Text.Lazy as LText
37+import Filesystem.Path.CurrentOS hiding (FilePath, root)
38+import Gen.Formatting (failure, shown)
39+import Gen.Import
40+import qualified Gen.JSON as JS
41+import Gen.Types
42+import Prelude hiding (mod)
43+import System.Directory.Tree hiding (file)
44+import Text.EDE hiding (failure, render)
45+
46+root :: AnchoredDirTree a -> Path
47+root (p :/ d) = decodeString p </> decodeString (name d)
48+
49+fold :: MonadError Error m
50+ => (Path -> m ()) -- ^ Directories
51+ -> (Path -> a -> m b) -- ^ Files
52+ -> AnchoredDirTree a
53+ -> m (AnchoredDirTree b)
54+fold g f (p :/ t) = (p :/) <$> go (decodeString p) t
55+ where
56+ go x = \case
57+ Failed n e -> failure shown e >> return (Failed n e)
58+ File n a -> File n <$> f (x </> decodeString n) a
59+ Dir n cs -> g d >> Dir n <$> mapM (go d) cs
60+ where
61+ d = x </> decodeString n
62+
63+-- If Nothing, then touch the file, otherwise write the Just contents.
64+type Touch = Maybe Rendered
65+
66+populate :: Path
67+ -> Templates
68+ -> Library
69+ -> Either Error (AnchoredDirTree Touch)
70+populate d Templates{..} l = (encodeString d :/) . dir lib <$> layout
71+ where
72+ layout :: Either Error [DirTree Touch]
73+ layout = traverse sequenceA
74+ [ dir "src"
75+ -- Supress cabal warnings about directories listed that don't exist.
76+ [ touch ".gitkeep"
77+ ]
78+
79+ , dir "gen"
80+ [ dir "Network"
81+ [ dir "Google" $
82+ concatMap service (NE.toList (_libServices l))
83+ ]
84+ ]
85+
86+ , file (lib <.> "cabal") cabalTemplate
87+ , file "README.md" readmeTemplate
88+ ]
89+
90+ service :: Service -> [DirTree (Either Error Touch)]
91+ service s =
92+ [ write $ module' (tocNS s) mempty tocTemplate (pure svc)
93+ , dir (fromText (svcAbbrev s))
94+ [ write $ module' (typesNS s) (typeImports s) typesTemplate (pure svc)
95+ ]
96+ ]
97+ where
98+ svc = toJSON s
99+
100+ lib :: Path
101+ lib = fromText (_libName l)
102+
103+ mod :: NS -> [NS] -> Template -> DirTree (Either Error Touch)
104+ mod n is t = write . module' n is t . pure $ toJSON l
105+
106+ file :: Path -> Template -> DirTree (Either Error Touch)
107+ file p t = write $ file' p t (pure env)
108+
109+ env :: Value
110+ env = toJSON l
111+
112+-- operation' :: Library
113+-- -> Template
114+-- -> Operation Identity SData a
115+-- -> DirTree (Either Error Rendered)
116+-- operation' l t o = module' n is t $ do
117+-- x <- JS.objectErr (show n) o
118+-- y <- JS.objectErr "metadata" (toJSON m)
119+-- return $! Map.insert "operationUrl" (toJSON u) (y <> x)
120+-- where
121+-- n = operationNS (l ^. libraryNS) (o ^. opName)
122+-- m = l ^. metadata
123+-- u = l ^. operationUrl
124+
125+-- is = operationImports l o
126+
127+module' :: ToJSON a
128+ => NS
129+ -> [NS]
130+ -> Template
131+ -> Either Error a
132+ -> DirTree (Either Error Rendered)
133+module' ns is t f = file' (filename $ nsToPath ns) t $ do
134+ x <- f >>= JS.objectErr (show ns)
135+ return $! x <> fromPairs
136+ [ "moduleName" .= ns
137+ , "moduleImports" .= is
138+ ]
139+
140+file' :: ToJSON a
141+ => Path
142+ -> Template
143+ -> Either Error a
144+ -> DirTree (Either Error Rendered)
145+file' (encodeString -> p) t f = File p $
146+ f >>= JS.objectErr p
147+ >>= fmapL LText.pack . eitherRender t
148+
149+dir :: Path -> [DirTree a] -> DirTree a
150+dir p = Dir (encodeString p)
151+
152+write :: DirTree (Either e a) -> DirTree (Either e (Maybe a))
153+write = fmap (second Just)
154+
155+touch :: Text -> DirTree (Either e (Maybe a))
156+touch f = File (Text.unpack f) (Right Nothing)
gen/src/Gen/Types.hs+66−23
@@ -1,7 +1,9 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE TemplateHaskell #-}
7{-# LANGUAGE TemplateHaskell #-}
6
8
7-- Module : Gen.Types
9-- Module : Gen.Types
@@ -11,9 +13,11 @@
11-- Stability : provisional
13-- Stability : provisional
12-- Portability : non-portable (GHC extensions)
14-- Portability : non-portable (GHC extensions)
13
15
14−module Gen.Types where
16+module Gen.Types
17+ ( module Gen.Types
18+ , module Gen.Types.NS
19+ ) where
15
20
16−--import Control.Lens
17import Data.Aeson
21import Data.Aeson
18import Data.Aeson.TH
22import Data.Aeson.TH
19import qualified Data.Attoparsec.Text as A
23import qualified Data.Attoparsec.Text as A
@@ -28,16 +32,20 @@ import Data.Semigroup
28import Data.Text (Text)
32import Data.Text (Text)
29import qualified Data.Text as Text
33import qualified Data.Text as Text
30import qualified Data.Text.Lazy as LText
34import qualified Data.Text.Lazy as LText
35+import qualified Data.Text.Lazy.Builder as Build
31import Data.Text.Manipulate
36import Data.Text.Manipulate
32import qualified Filesystem.Path.CurrentOS as Path
37import qualified Filesystem.Path.CurrentOS as Path
33−import Gen.JSON
38+import Formatting
39+import Gen.Text
34import Gen.Types.NS
40import Gen.Types.NS
41+import GHC.Generics
35import GHC.TypeLits
42import GHC.TypeLits
36import Text.EDE (Template)
43import Text.EDE (Template)
37
44
38−type Map = Map.HashMap
45+type Map = Map.HashMap
39−type Error = LText.Text
46+type Error = LText.Text
47+type Rendered = LText.Text
40−type Path = Path.FilePath
48+type Path = Path.FilePath
41
49
42toTextIgnore :: Path -> Text
50toTextIgnore :: Path -> Text
43toTextIgnore = either id id . Path.toText
51toTextIgnore = either id id . Path.toText
@@ -53,6 +61,12 @@ data Templates = Templates
53newtype Version (v :: Symbol) = Version Text
61newtype Version (v :: Symbol) = Version Text
54 deriving (Eq, Show)
62 deriving (Eq, Show)
55
63
64+instance ToJSON (Version v) where
65+ toJSON (Version v) = toJSON v
66+
67+semver :: Format a (Version v -> a)
68+semver = later (\(Version v) -> Build.fromText v)
69+
56type LibraryVer = Version "library"
70type LibraryVer = Version "library"
57type ClientVer = Version "client"
71type ClientVer = Version "client"
58type CoreVer = Version "core"
72type CoreVer = Version "core"
@@ -63,8 +77,6 @@ data Versions = Versions
63 , _coreVersion :: CoreVer
77 , _coreVersion :: CoreVer
64 } deriving (Show)
78 } deriving (Show)
65
79
66−-- makeClassy ''Versions
67−
68-- FIXME: need a more comprehensive 'vm_alpha' vs 'vm1.1' etc check.
80-- FIXME: need a more comprehensive 'vm_alpha' vs 'vm1.1' etc check.
69data Spec = Spec
81data Spec = Spec
70 { _specName :: Text
82 { _specName :: Text
@@ -102,8 +114,12 @@ instance FromJSON Protocol where
102 "rest" -> pure REST
114 "rest" -> pure REST
103 e -> fail $ "Unable to parse protocol from " ++ Text.unpack e
115 e -> fail $ "Unable to parse protocol from " ++ Text.unpack e
104
116
117+instance ToJSON Protocol where
118+ toJSON = toJSON . map toLower . show
119+
105data Service = Service
120data Service = Service
121+ { _svcLibrary :: Text
106− { _svcTitle :: Text
122+ , _svcTitle :: Text
107 , _svcName :: Text
123 , _svcName :: Text
108 , _svcCanonicalName :: Maybe Text
124 , _svcCanonicalName :: Maybe Text
109 , _svcDescription :: Text
125 , _svcDescription :: Text
@@ -121,30 +137,57 @@ data Service = Service
121 , _svcParameters :: Object
137 , _svcParameters :: Object
122 , _svcAuth :: Maybe Object
138 , _svcAuth :: Maybe Object
123 , _svcSchemas :: Object
139 , _svcSchemas :: Object
124− } deriving (Show)
140+ } deriving (Show, Generic)
125
141
126deriveFromJSON (js "_svc") ''Service
142deriveFromJSON (js "_svc") ''Service
127
143
144+instance ToJSON Service where
145+ toJSON s = Object (x <> y)
146+ where
147+ Object x = genericToJSON (js "_svc") s
148+ Object y = object
149+ [ "exposedModules" .= exposedModules s
150+ ]
151+
152+svcAbbrev :: Service -> Text
153+svcAbbrev = renameAbbrev . _svcTitle
154+
155+typeImports :: Service -> [NS]
156+typeImports _ = ["Network.Google.Prelude"]
157+
158+tocNS, typesNS :: Service -> NS
159+tocNS s = NS ["Network", "Google", svcAbbrev s]
160+typesNS = (<> "Types") . tocNS
161+
162+exposedModules :: Service -> [NS]
163+exposedModules s = [tocNS s, typesNS s]
164+
128data Library = Library
165data Library = Library
129− { _libName :: Text
166+ { _libName :: Text
130− , _libTitle :: Text
167+ , _libTitle :: Text
131− , _libDescriptions :: [Text]
132− , _libNamespace :: NS
133− , _libVersions :: Versions
168+ , _libVersions :: Versions
134− , _libServices :: NonEmpty Service
169+ , _libServices :: NonEmpty Service
135 }
170 }
136
171
172+instance ToJSON Library where
173+ toJSON Library{..} = object
174+ [ "libraryName" .= _libName
175+ , "libraryTitle" .= _libTitle
176+ , "libraryVersion" .= _libraryVersion _libVersions
177+ , "coreVersion" .= _coreVersion _libVersions
178+ , "clientVersion" .= _clientVersion _libVersions
179+ , "exposedModules" .= concatMap exposedModules (NE.toList _libServices)
180+ ]
181+
137mergeLibraries :: Versions -> [Service] -> [Library]
182mergeLibraries :: Versions -> [Service] -> [Library]
138−mergeLibraries v = map go . groupBy (on (==) _svcName)
183+mergeLibraries v = map go . groupBy (on (==) _svcLibrary)
139 where
184 where
140 go [x] = mk x
185 go [x] = mk x
141 go (x:xs) = (mk x) { _libServices = x :| xs }
186 go (x:xs) = (mk x) { _libServices = x :| xs }
142
187
143 mk x = Library
188 mk x = Library
144− { _libName = "gozen-" <> Text.toLower (_svcName x)
189+ { _libName = _svcLibrary x
145− , _libTitle = _svcTitle x
190+ , _libTitle = renameTitle (_svcTitle x)
146− , _libDescriptions = []
147− , _libNamespace = "Network.Google" <> mkNS (toPascal (_svcName x))
148− , _libVersions = v
191+ , _libVersions = v
149− , _libServices = x :| []
192+ , _libServices = x :| []
150 }
193 }
gen/src/Gen/Types/NS.hs+11
@@ -10,6 +10,8 @@
10module Gen.Types.NS where
10module Gen.Types.NS where
11
11
12import Data.Aeson
12import Data.Aeson
13+import Data.Aeson.Types
14+import Data.Char
13import Data.Monoid
15import Data.Monoid
14import Data.Semigroup
16import Data.Semigroup
15import Data.String
17import Data.String
@@ -45,3 +47,12 @@ instance FromJSON NS where
45
47
46instance ToJSON NS where
48instance ToJSON NS where
47 toJSON (NS xs) = toJSON (Text.intercalate "." xs)
49 toJSON (NS xs) = toJSON (Text.intercalate "." xs)
50+
51+-- Wut?
52+js :: String -> Options
53+js pre = defaultOptions
54+ { constructorTagModifier = map toLower
55+ , fieldLabelModifier = \s ->
56+ let x:xs = drop (length pre) s
57+ in toLower x : xs
58+ }
gen/src/Main.hs+25−28
@@ -14,7 +14,8 @@
14
14
15module Main (main) where
15module Main (main) where
16
16
17−import Control.Lens
17+import Control.Error
18+import Control.Lens hiding ((<.>))
18import Control.Monad.State
19import Control.Monad.State
19import Data.List (nub, sort)
20import Data.List (nub, sort)
20import Data.String
21import Data.String
@@ -25,12 +26,14 @@ import Filesystem.Path.CurrentOS
25import Gen.Formatting
26import Gen.Formatting
26import Gen.IO
27import Gen.IO
27import qualified Gen.JSON as JS
28import qualified Gen.JSON as JS
29+import qualified Gen.Tree as Tree
28import Gen.Types
30import Gen.Types
29import Options.Applicative
31import Options.Applicative
30
32
31data Opt = Opt
33data Opt = Opt
32 { _optOutput :: Path
34 { _optOutput :: Path
33 , _optModels :: [Path]
35 , _optModels :: [Path]
36+ , _optAnnexes :: Path
34 , _optTemplates :: Path
37 , _optTemplates :: Path
35 , _optStatic :: Path
38 , _optStatic :: Path
36 , _optVersions :: Versions
39 , _optVersions :: Versions
@@ -52,6 +55,12 @@ parser = Opt
52 <> help "Directory for a service's botocore models."
55 <> help "Directory for a service's botocore models."
53 ))
56 ))
54
57
58+ <*> option isPath
59+ ( long "annexes"
60+ <> metavar "DIR"
61+ <> help "Directory containing botocore model annexes."
62+ )
63+
55 <*> option isPath
64 <*> option isPath
56 ( long "templates"
65 ( long "templates"
57 <> metavar "DIR"
66 <> metavar "DIR"
@@ -96,6 +105,7 @@ validate :: MonadIO m => Opt -> m Opt
96validate o = flip execStateT o $ do
105validate o = flip execStateT o $ do
97 sequence_
106 sequence_
98 [ check optOutput
107 [ check optOutput
108+ , check optAnnexes
99 , check optTemplates
109 , check optTemplates
100 , check optStatic
110 , check optStatic
101 ]
111 ]
@@ -128,13 +138,18 @@ main = do
128 <*> load "types.ede"
138 <*> load "types.ede"
129 <* lift done
139 <* lift done
130
140
141+ title "Selecting new service models..."
131 say ("Found " % int % " model specifications.") (length _optModels)
142 say ("Found " % int % " model specifications.") (length _optModels)
132 say ("Selected " % int % " newest models.") i
143 say ("Selected " % int % " newest models.") i
144+ done
133
145
134 svcs <- counter "model" ss $ \Spec{..} -> do
146 svcs <- counter "model" ss $ \Spec{..} -> do
135 say ("Using version " % stext) _specVersion
147 say ("Using version " % stext) _specVersion
136
148
149+ s <- sequence
150+ [ JS.load (_optAnnexes </> fromText _specName <.> "json")
137− s <- readBSFile _specPath >>= JS.decode
151+ , JS.load _specPath
152+ ] >>= hoistEither . JS.parse . JS.merge
138
153
139 say ("Successfully parsed '" % stext % "' API definition.")
154 say ("Successfully parsed '" % stext % "' API definition.")
140 (_svcTitle s)
155 (_svcTitle s)
@@ -145,33 +160,19 @@ main = do
145
160
146 let libs = mergeLibraries _optVersions svcs
161 let libs = mergeLibraries _optVersions svcs
147
162
148− _ <- counter "library" libs $ \l -> do
163+ void . counter "library" libs $ \l -> do
149 say ("Creating " % stext % " package.") (_libTitle l)
164 say ("Creating " % stext % " package.") (_libTitle l)
150
165
151− done
166+ dir <- hoistEither (Tree.populate _optOutput tmpl l)
152−
167+ >>= Tree.fold createDir (\x -> maybe (touchFile x) (writeLTFile x))
153−-- say ("Service: " % string) (
154−
155− -- api <- sequence
156− -- [ JS.optional (_optAnnexes </> (m ^. annexFile))
157− -- , JS.required (m ^. serviceFile)
158− -- , JS.optional (m ^. waitersFile)
159− -- , JS.optional (m ^. pagersFile)
160− -- , pure r
161− -- ] >>= hoistEither . JS.parse . JS.merge
162−
163− -- lib <- hoistEither (AST.rewrite _optVersions cfg api)
164
168
165− -- dir <- hoistEither (Tree.populate _optOutput tmpl lib)
169+ say ("Successfully rendered " % stext % "-" % semver % " package")
166− -- >>= Tree.fold createDir (\x -> maybe (touchFile x) (writeLTFile x))
170+ (_libName l)
171+ (_libraryVersion _optVersions)
167
172
168− -- say ("Successfully rendered " % stext % "-" % semver % " package")
173+ copyDir _optStatic (Tree.root dir)
169− -- (lib ^. libraryName)
170− -- (lib ^. libraryVersion)
171
174
172− -- copyDir _optStatic (Tree.root dir)
173−
174− -- done
175+ done
175
176
176 title ("Successfully processed " % int % " models.") i
177 title ("Successfully processed " % int % " models.") i
177 title ("Successfully created " % int % " library packages.") (length libs)
178 title ("Successfully created " % int % " library packages.") (length libs)
@@ -180,10 +181,6 @@ class HasName a where getName :: a -> Text
180instance HasName Spec where getName = _specName
181instance HasName Spec where getName = _specName
181instance HasName Library where getName = _libName
182instance HasName Library where getName = _libName
182
183
183−-- counter :: (MonadIO n, m ~ ExceptT n Error, HasName a)
184−-- => [a]
185−-- -> (a -> m b)
186−-- -> m [b]
187counter k xs f = forM (zip [1..] xs) $ \(n, x) -> do
184counter k xs f = forM (zip [1..] xs) $ \(n, x) -> do
188 title ("[" % int % "/" % int % "] " % stext % ":" % stext)
185 title ("[" % int % "/" % int % "] " % stext % ":" % stext)
189 (n :: Int) i k (getName x)
186 (n :: Int) i k (getName x)