git.iko.soy/gogol
on develop help sign in
Rendering basic toc + types modules + library skeleton
commit53af420cdcd66921fe346bd0c17f7d4fc355f194 authorBrendan Hay <brendan.g.hay@gmail.com> dateTue 22 Sep 2015, 17:15 (11 years ago) parent4278cc5
7 files changed+433−119
compare with develop
unifiedsplit
gen/src/Gen/IO.hs+27−29 gen/src/Gen/JSON.hs+29−39 gen/src/Gen/Text.hs+119 gen/src/Gen/Tree.hs+156 gen/src/Gen/Types.hs+66−23 gen/src/Gen/Types/NS.hs+11 gen/src/Main.hs+25−28
gen/src/Gen/IO.hs+27−29
@@ -24,6 +24,7 @@ import qualified Filesystem as FS
2424import Filesystem.Path.CurrentOS
2525import Gen.Formatting
2626import Gen.Types
27+import System.IO
2728import qualified Text.EDE as EDE
2829
2930run :: ExceptT Error IO a -> IO a
@@ -44,9 +45,6 @@ done = title ""
4445isFile :: MonadIO m => Path -> ExceptT Error m Bool
4546isFile = io . FS.isFile
4647
47−-- listDir :: MonadIO m => Path -> ExceptT Error m [Path]
48−-- listDir = io . FS.listDirectory
49−
5048readBSFile :: MonadIO m => Path -> ExceptT Error m ByteString
5149readBSFile f = do
5250 p <- isFile f
@@ -54,33 +52,33 @@ readBSFile f = do
5452 then say ("Reading " % path) f >> io (FS.readFile f)
5553 else failure ("Missing " % path) f
5654
57−-- writeLTFile :: MonadIO m => Path -> LText.Text -> ExceptT Error m ()
58−-- writeLTFile f t = do
59−-- say ("Writing " % path) f
60−-- io . FS.withFile f FS.WriteMode $ \h -> do
61−-- hSetEncoding h utf8
62−-- 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)
55+writeLTFile :: MonadIO m => Path -> LText.Text -> ExceptT Error m ()
56+writeLTFile f t = do
57+ say ("Writing " % path) f
58+ io . FS.withFile f FS.WriteMode $ \h -> do
59+ hSetEncoding h utf8
60+ LText.hPutStr h t
7661
77−-- copyDir :: MonadIO m => Path -> Path -> ExceptT Error m ()
78−-- copyDir src dst = io (FS.listDirectory src >>= mapM_ copy)
79−-- where
80−-- copy f = do
81−-- let p = dst </> filename f
82−-- fprint (" -> Copying " % path % " to " % path % "\n") f (directory p)
83−-- FS.copyFile f p
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+
75+copyDir :: MonadIO m => Path -> Path -> ExceptT Error m ()
76+copyDir src dst = io (FS.listDirectory src >>= mapM_ copy)
77+ where
78+ copy f = do
79+ let p = dst </> filename f
80+ fprint (" -> Copying " % path % " to " % path % "\n") f (directory p)
81+ FS.copyFile f p
8482
8583readTemplate :: MonadIO m
8684 => Path
gen/src/Gen/JSON.hs+29−39
@@ -17,47 +17,37 @@ import Data.Aeson.Types
1717import Data.Bifunctor
1818import Data.ByteString (ByteString)
1919import qualified Data.ByteString.Lazy as LBS
20−import Data.Char
2120import qualified Data.HashMap.Strict as Map
2221import Data.List
2322import qualified Data.Text.Lazy as LText
23+import Gen.Formatting
24+import Gen.IO
25+import Gen.Types
2426import qualified Text.EDE as EDE
2527
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
42−-- objectErr n =
43−-- note (format ("Failed to extract JSON object from value " % string) n)
44−-- . EDE.fromValue
45−-- . toJSON
46−
47−-- decode :: FromJByteString -> Either Error a
48−-- decode = first LText.pack . eitherDecode' . LBS.fromStrict
49−
50−-- parse :: FromJSON a => Object -> Either Error a
51−-- parse = first LText.pack . parseEither parseJSON . Object
52−
53−-- merge :: [Object] -> Object
54−-- merge = foldl' go mempty
55−-- where
56−-- go :: Object -> Object -> Object
57−-- go = Map.unionWith value
58−
59−-- value :: Value -> Value -> Value
60−-- value l r =
61−-- case (l, r) of
62−-- (Object x, Object y) -> Object (x `go` y)
63−-- (_, _) -> l
28+objectErr :: ToJSON a => String -> a -> Either Error Object
29+objectErr n =
30+ note (format ("Failed to extract JSON object from value " % string) n)
31+ . EDE.fromValue
32+ . toJSON
33+
34+load :: MonadIO m => Path -> ExceptT Error m Object
35+load = readBSFile >=> hoistEither . decode
36+
37+decode :: ByteString -> Either Error Object
38+decode = first LText.pack . eitherDecode' . LBS.fromStrict
39+
40+parse :: FromJSON a => Object -> Either Error a
41+parse = first LText.pack . parseEither parseJSON . Object
42+
43+merge :: [Object] -> Object
44+merge = foldl' go mempty
45+ where
46+ go :: Object -> Object -> Object
47+ go = Map.unionWith value
48+
49+ value :: Value -> Value -> Value
50+ value l r =
51+ case (l, r) of
52+ (Object x, Object y) -> Object (x `go` y)
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 @@
11{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
23{-# LANGUAGE KindSignatures #-}
34{-# LANGUAGE LambdaCase #-}
45{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE RecordWildCards #-}
57{-# LANGUAGE TemplateHaskell #-}
68
79-- Module : Gen.Types
@@ -11,9 +13,11 @@
1113-- Stability : provisional
1214-- Portability : non-portable (GHC extensions)
1315
14−module Gen.Types where
16+module Gen.Types
17+ ( module Gen.Types
18+ , module Gen.Types.NS
19+ ) where
1520
16−--import Control.Lens
1721import Data.Aeson
1822import Data.Aeson.TH
1923import qualified Data.Attoparsec.Text as A
@@ -28,16 +32,20 @@ import Data.Semigroup
2832import Data.Text (Text)
2933import qualified Data.Text as Text
3034import qualified Data.Text.Lazy as LText
35+import qualified Data.Text.Lazy.Builder as Build
3136import Data.Text.Manipulate
3237import qualified Filesystem.Path.CurrentOS as Path
33−import Gen.JSON
38+import Formatting
39+import Gen.Text
3440import Gen.Types.NS
41+import GHC.Generics
3542import GHC.TypeLits
3643import Text.EDE (Template)
3744
38−type Map = Map.HashMap
39−type Error = LText.Text
40−type Path = Path.FilePath
45+type Map = Map.HashMap
46+type Error = LText.Text
47+type Rendered = LText.Text
48+type Path = Path.FilePath
4149
4250toTextIgnore :: Path -> Text
4351toTextIgnore = either id id . Path.toText
@@ -53,6 +61,12 @@ data Templates = Templates
5361newtype Version (v :: Symbol) = Version Text
5462 deriving (Eq, Show)
5563
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+
5670type LibraryVer = Version "library"
5771type ClientVer = Version "client"
5872type CoreVer = Version "core"
@@ -63,8 +77,6 @@ data Versions = Versions
6377 , _coreVersion :: CoreVer
6478 } deriving (Show)
6579
66−-- makeClassy ''Versions
67−
6880-- FIXME: need a more comprehensive 'vm_alpha' vs 'vm1.1' etc check.
6981data Spec = Spec
7082 { _specName :: Text
@@ -102,8 +114,12 @@ instance FromJSON Protocol where
102114 "rest" -> pure REST
103115 e -> fail $ "Unable to parse protocol from " ++ Text.unpack e
104116
117+instance ToJSON Protocol where
118+ toJSON = toJSON . map toLower . show
119+
105120data Service = Service
106− { _svcTitle :: Text
121+ { _svcLibrary :: Text
122+ , _svcTitle :: Text
107123 , _svcName :: Text
108124 , _svcCanonicalName :: Maybe Text
109125 , _svcDescription :: Text
@@ -121,30 +137,57 @@ data Service = Service
121137 , _svcParameters :: Object
122138 , _svcAuth :: Maybe Object
123139 , _svcSchemas :: Object
124− } deriving (Show)
140+ } deriving (Show, Generic)
125141
126142deriveFromJSON (js "_svc") ''Service
127143
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+
128165data Library = Library
129− { _libName :: Text
130− , _libTitle :: Text
131− , _libDescriptions :: [Text]
132− , _libNamespace :: NS
133− , _libVersions :: Versions
134− , _libServices :: NonEmpty Service
166+ { _libName :: Text
167+ , _libTitle :: Text
168+ , _libVersions :: Versions
169+ , _libServices :: NonEmpty Service
135170 }
136171
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+
137182mergeLibraries :: Versions -> [Service] -> [Library]
138−mergeLibraries v = map go . groupBy (on (==) _svcName)
183+mergeLibraries v = map go . groupBy (on (==) _svcLibrary)
139184 where
140185 go [x] = mk x
141186 go (x:xs) = (mk x) { _libServices = x :| xs }
142187
143188 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 :| []
189+ { _libName = _svcLibrary x
190+ , _libTitle = renameTitle (_svcTitle x)
191+ , _libVersions = v
192+ , _libServices = x :| []
150193 }
gen/src/Gen/Types/NS.hs+11
@@ -10,6 +10,8 @@
1010module Gen.Types.NS where
1111
1212import Data.Aeson
13+import Data.Aeson.Types
14+import Data.Char
1315import Data.Monoid
1416import Data.Semigroup
1517import Data.String
@@ -45,3 +47,12 @@ instance FromJSON NS where
4547
4648instance ToJSON NS where
4749 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 @@
1414
1515module Main (main) where
1616
17−import Control.Lens
17+import Control.Error
18+import Control.Lens hiding ((<.>))
1819import Control.Monad.State
1920import Data.List (nub, sort)
2021import Data.String
@@ -25,12 +26,14 @@ import Filesystem.Path.CurrentOS
2526import Gen.Formatting
2627import Gen.IO
2728import qualified Gen.JSON as JS
29+import qualified Gen.Tree as Tree
2830import Gen.Types
2931import Options.Applicative
3032
3133data Opt = Opt
3234 { _optOutput :: Path
3335 , _optModels :: [Path]
36+ , _optAnnexes :: Path
3437 , _optTemplates :: Path
3538 , _optStatic :: Path
3639 , _optVersions :: Versions
@@ -52,6 +55,12 @@ parser = Opt
5255 <> help "Directory for a service's botocore models."
5356 ))
5457
58+ <*> option isPath
59+ ( long "annexes"
60+ <> metavar "DIR"
61+ <> help "Directory containing botocore model annexes."
62+ )
63+
5564 <*> option isPath
5665 ( long "templates"
5766 <> metavar "DIR"
@@ -96,6 +105,7 @@ validate :: MonadIO m => Opt -> m Opt
96105validate o = flip execStateT o $ do
97106 sequence_
98107 [ check optOutput
108+ , check optAnnexes
99109 , check optTemplates
100110 , check optStatic
101111 ]
@@ -128,13 +138,18 @@ main = do
128138 <*> load "types.ede"
129139 <* lift done
130140
141+ title "Selecting new service models..."
131142 say ("Found " % int % " model specifications.") (length _optModels)
132143 say ("Selected " % int % " newest models.") i
144+ done
133145
134146 svcs <- counter "model" ss $ \Spec{..} -> do
135147 say ("Using version " % stext) _specVersion
136148
137− s <- readBSFile _specPath >>= JS.decode
149+ s <- sequence
150+ [ JS.load (_optAnnexes </> fromText _specName <.> "json")
151+ , JS.load _specPath
152+ ] >>= hoistEither . JS.parse . JS.merge
138153
139154 say ("Successfully parsed '" % stext % "' API definition.")
140155 (_svcTitle s)
@@ -145,33 +160,19 @@ main = do
145160
146161 let libs = mergeLibraries _optVersions svcs
147162
148− _ <- counter "library" libs $ \l -> do
163+ void . counter "library" libs $ \l -> do
149164 say ("Creating " % stext % " package.") (_libTitle l)
150165
151− done
152−
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)
166+ dir <- hoistEither (Tree.populate _optOutput tmpl l)
167+ >>= Tree.fold createDir (\x -> maybe (touchFile x) (writeLTFile x))
164168
165− -- dir <- hoistEither (Tree.populate _optOutput tmpl lib)
166− -- >>= Tree.fold createDir (\x -> maybe (touchFile x) (writeLTFile x))
169+ say ("Successfully rendered " % stext % "-" % semver % " package")
170+ (_libName l)
171+ (_libraryVersion _optVersions)
167172
168− -- say ("Successfully rendered " % stext % "-" % semver % " package")
169− -- (lib ^. libraryName)
170− -- (lib ^. libraryVersion)
173+ copyDir _optStatic (Tree.root dir)
171174
172− -- copyDir _optStatic (Tree.root dir)
173−
174− -- done
175+ done
175176
176177 title ("Successfully processed " % int % " models.") i
177178 title ("Successfully created " % int % " library packages.") (length libs)
@@ -180,10 +181,6 @@ class HasName a where getName :: a -> Text
180181instance HasName Spec where getName = _specName
181182instance HasName Library where getName = _libName
182183
183−-- counter :: (MonadIO n, m ~ ExceptT n Error, HasName a)
184−-- => [a]
185−-- -> (a -> m b)
186−-- -> m [b]
187184counter k xs f = forM (zip [1..] xs) $ \(n, x) -> do
188185 title ("[" % int % "/" % int % "] " % stext % ":" % stext)
189186 (n :: Int) i k (getName x)