Skip to content

Commit 0efa40b

Browse files
philderbeastphilderbeast
committed
Add config get and dump commands.
Get the project resolver. Add config get commands. Get project system-ghc and install-ghc. Extract duplicated as logBool. Show scope. Don't log the key asked for. Should have been NoReexec. Get and Modify variants of scopeFlag help. Dump the project's configuration. Pipe to common functions for config list. Add scope and distinguish what is being dumped. Extract encodeDump* functions. First pass at dump-project and dump-stack. Separate project and stack dumps more. Add DumpStackScope and --lens option. Parse what is needed for the dump. Fix typos and improve help string. Allow for missing stack settings in the project. Fix a typo, aronud. Better explain effective scope. Drop the --global option when dumping the project.
1 parent 4bf7c96 commit 0efa40b

File tree

2 files changed

+288
-45
lines changed

2 files changed

+288
-45
lines changed

‎src/Stack/ConfigCmd.hs

Lines changed: 275 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,53 @@
1+
{-# LANGUAGE DerivingStrategies #-}
12
{-# LANGUAGE NoImplicitPrelude #-}
23
{-# LANGUAGE ConstraintKinds #-}
34
{-# LANGUAGE FlexibleContexts #-}
45
{-# LANGUAGE GADTs #-}
56
{-# LANGUAGE OverloadedStrings #-}
67
{-# LANGUAGE ScopedTypeVariables #-}
8+
{-# LANGUAGE LambdaCase #-}
9+
{-# LANGUAGE TupleSections #-}
10+
{-# LANGUAGE RecordWildCards #-}
711

812
-- | Make changes to project or global configuration.
913
module Stack.ConfigCmd
10-
(ConfigCmdSet(..)
14+
(cfgCmdName
15+
16+
-- * config dump project
17+
,ConfigCmdDumpProject(..)
18+
,configCmdDumpProjectParser
19+
,cfgCmdDumpProject
20+
,cfgCmdDumpProjectName
21+
22+
-- * config dump stack
23+
,ConfigCmdDumpStack(..)
24+
,configCmdDumpStackParser
25+
,cfgCmdDumpStack
26+
,cfgCmdDumpStackName
27+
28+
-- * config get
29+
,ConfigCmdGet(..)
30+
,configCmdGetParser
31+
,cfgCmdGet
32+
,cfgCmdGetName
33+
34+
-- * config set
35+
,ConfigCmdSet(..)
1136
,configCmdSetParser
1237
,cfgCmdSet
1338
,cfgCmdSetName
39+
40+
-- * config env
1441
,configCmdEnvParser
1542
,cfgCmdEnv
1643
,cfgCmdEnvName
17-
,cfgCmdName) where
44+
) where
1845

1946
import Stack.Prelude
2047
import Data.Coerce (coerce)
48+
import Pantry.Internal.AesonExtended
49+
(ToJSON(..), FromJSON, (.=), WithJSONWarnings (WithJSONWarnings), object)
50+
import qualified Data.Aeson as Aeson
2151
import qualified Data.Aeson.Key as Key
2252
import qualified Data.Aeson.KeyMap as KeyMap
2353
import Data.ByteString.Builder (byteString)
@@ -39,40 +69,190 @@ import Stack.Types.Resolver
3969
import System.Environment (getEnvironment)
4070
import Stack.YamlUpdate
4171

72+
data ConfigDumpFormat = ConfigDumpYaml | ConfigDumpJson
73+
74+
-- | Dump project configuration settings.
75+
newtype ConfigCmdDumpProject = ConfigCmdDumpProject ConfigDumpFormat
76+
77+
-- | Dump stack's own settings. Configuration related to its own opertion. This
78+
-- can be defaulted or stored in a global location or project location or both,
79+
-- in @~\/.stack\/config.yaml@ or @stack.yaml@.
80+
data ConfigCmdDumpStack = ConfigCmdDumpStack DumpStackScope ConfigDumpFormat
81+
82+
-- | Get configuration items that can be individually set by `stack config set`.
83+
data ConfigCmdGet
84+
= ConfigCmdGetResolver
85+
| ConfigCmdGetSystemGhc CommandScope
86+
| ConfigCmdGetInstallGhc CommandScope
87+
88+
-- | Set the resolver for the project or set compiler-related configuration at
89+
-- project or global scope.
4290
data ConfigCmdSet
4391
= ConfigCmdSetResolver (Unresolved AbstractResolver)
44-
| ConfigCmdSetSystemGhc CommandScope
45-
Bool
46-
| ConfigCmdSetInstallGhc CommandScope
47-
Bool
92+
| ConfigCmdSetSystemGhc CommandScope Bool
93+
| ConfigCmdSetInstallGhc CommandScope Bool
4894

95+
-- | Where to get the configuration settings from.
4996
data CommandScope
5097
= CommandScopeGlobal
51-
-- ^ Apply changes to the global configuration,
52-
-- typically at @~/.stack/config.yaml@.
98+
-- ^ Apply changes to or get settings from the global configuration,
99+
-- typically at @~\/.stack\/config.yaml@.
53100
| CommandScopeProject
54-
-- ^ Apply changes to the project @stack.yaml@.
101+
-- ^ Apply changes to or get settings from the project @stack.yaml@.
102+
103+
-- | Where to get the configuration settings from.
104+
data DumpStackScope
105+
= DumpStackScopeEffective
106+
-- ^ A view of settings where those settings in the project but related to
107+
-- stack's own operation override settings in the global location.
108+
| DumpStackScopeGlobal
109+
-- ^ Apply changes to or get settings from the global configuration,
110+
-- typically at @~\/.stack\/config.yaml@.
111+
| DumpStackScopeProject
112+
-- ^ Apply changes to or get settings from the project @stack.yaml@.
113+
114+
instance Display CommandScope where
115+
display CommandScopeProject = "project"
116+
display CommandScopeGlobal = "global"
117+
118+
configCmdGetScope :: ConfigCmdGet -> CommandScope
119+
configCmdGetScope ConfigCmdGetResolver = CommandScopeProject
120+
configCmdGetScope (ConfigCmdGetSystemGhc scope) = scope
121+
configCmdGetScope (ConfigCmdGetInstallGhc scope) = scope
55122

56123
configCmdSetScope :: ConfigCmdSet -> CommandScope
57124
configCmdSetScope (ConfigCmdSetResolver _) = CommandScopeProject
58125
configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope
59126
configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope
60127

61-
cfgCmdSet
62-
:: (HasConfig env, HasGHCVariant env)
63-
=> ConfigCmdSet -> RIO env ()
64-
cfgCmdSet cmd = do
128+
encodeDumpProject :: ConfigDumpFormat -> (Project -> ByteString)
129+
encodeDumpProject ConfigDumpYaml = Yaml.encode
130+
encodeDumpProject ConfigDumpJson = toStrictBytes . Aeson.encode
131+
132+
encodeDumpStackBy :: ToJSON a => (Config -> a) -> ConfigCmdDumpStack -> (Config -> ByteString)
133+
encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpYaml) = Yaml.encode . f
134+
encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpJson) = toStrictBytes . Aeson.encode . f
135+
136+
encodeDumpStack :: ConfigDumpFormat -> (DumpStack -> ByteString)
137+
encodeDumpStack ConfigDumpYaml = Yaml.encode
138+
encodeDumpStack ConfigDumpJson = toStrictBytes . Aeson.encode
139+
140+
cfgReadProject :: (HasConfig env, HasLogFunc env) => CommandScope -> RIO env (Maybe Project)
141+
cfgReadProject scope = do
142+
(configFilePath, yamlConfig) <- cfgRead scope
143+
let parser = parseProjectAndConfigMonoid (parent configFilePath)
144+
case Yaml.parseEither parser yamlConfig of
145+
Left err -> do
146+
logError . display $ T.pack err
147+
return Nothing
148+
Right (WithJSONWarnings res _warnings) -> do
149+
ProjectAndConfigMonoid project _ <- liftIO res
150+
return $ Just project
151+
152+
cfgCmdDumpProject :: (HasConfig env, HasLogFunc env) => ConfigCmdDumpProject -> RIO env ()
153+
cfgCmdDumpProject (ConfigCmdDumpProject dumpFormat) = do
154+
project <- cfgReadProject CommandScopeProject
155+
project & maybe (logError "Couldn't find project") (\p ->
156+
encodeDumpProject dumpFormat p
157+
& decodeUtf8'
158+
& either throwM (logInfo . display))
159+
160+
data DumpStack =
161+
DumpStack
162+
{ dsInstallGHC :: !(Maybe Bool)
163+
, dsSystemGHC :: !(Maybe Bool)
164+
}
165+
166+
instance ToJSON DumpStack where
167+
toJSON DumpStack{..} = object
168+
[ "install-GHC" .= toJSON dsInstallGHC
169+
, "system-GHC" .= toJSON dsSystemGHC
170+
]
171+
172+
cfgCmdDumpStack :: (HasConfig env, HasLogFunc env) => ConfigCmdDumpStack -> RIO env ()
173+
cfgCmdDumpStack cmd@(ConfigCmdDumpStack scope dumpFormat)
174+
| DumpStackScopeEffective <- scope = cfgCmdDumpStackEffective cmd
175+
| DumpStackScopeProject <- scope = cfgDumpStack CommandScopeProject dumpFormat
176+
| DumpStackScopeGlobal <- scope = cfgDumpStack CommandScopeGlobal dumpFormat
177+
178+
cfgDumpStack
179+
:: (HasConfig env, HasLogFunc env)
180+
=> CommandScope -> ConfigDumpFormat -> RIO env ()
181+
cfgDumpStack scope dumpFormat = do
182+
(configFilePath, yamlConfig) <- cfgRead scope
183+
let parser = parseConfigMonoid (parent configFilePath)
184+
case Yaml.parseEither parser yamlConfig of
185+
Left err -> logError . display $ T.pack err
186+
Right (WithJSONWarnings config _warnings) -> do
187+
let dsSystemGHC = getFirst $ configMonoidSystemGHC config
188+
let dsInstallGHC = getFirstTrue $ configMonoidInstallGHC config
189+
190+
DumpStack{..}
191+
& encodeDumpStack dumpFormat
192+
& decodeUtf8'
193+
& either throwM (logInfo . display)
194+
195+
cfgCmdDumpStackEffective :: (HasConfig env, HasLogFunc env) => ConfigCmdDumpStack -> RIO env ()
196+
cfgCmdDumpStackEffective cmd = do
197+
conf <- view configL
198+
let f Config{..} =
199+
DumpStack
200+
{ dsInstallGHC = Just configInstallGHC
201+
, dsSystemGHC = Just configSystemGHC
202+
}
203+
conf
204+
& encodeDumpStackBy f cmd
205+
& decodeUtf8'
206+
& either throwM (logInfo . display)
207+
208+
cfgCmdGet :: (HasConfig env, HasLogFunc env) => ConfigCmdGet -> RIO env ()
209+
cfgCmdGet cmd = do
210+
let logBool maybeValue = logInfo $
211+
maybe "default" (display . T.toLower . T.pack . show) maybeValue
212+
213+
(configFilePath, yamlConfig) <- cfgRead (configCmdGetScope cmd)
214+
let parser = parseProjectAndConfigMonoid (parent configFilePath)
215+
case Yaml.parseEither parser yamlConfig of
216+
Left err -> logError . display $ T.pack err
217+
Right (WithJSONWarnings res _warnings) -> do
218+
ProjectAndConfigMonoid project config <- liftIO res
219+
cmd & \case
220+
ConfigCmdGetResolver ->
221+
logInfo . display $ projectResolver project
222+
ConfigCmdGetSystemGhc{} ->
223+
logBool (getFirst $ configMonoidSystemGHC config)
224+
ConfigCmdGetInstallGhc{} ->
225+
logBool (getFirstTrue $ configMonoidInstallGHC config)
226+
227+
-- | Configuration location for a scope. Typically:
228+
-- * at @~\/.stack\/config.yaml@ for global scope.
229+
-- * at @.\/stack.yaml@ by default or from the @--stack-yaml@ option for project scope.
230+
cfgLocation :: HasConfig s => CommandScope -> RIO s (Path Abs File)
231+
cfgLocation scope = do
65232
conf <- view configL
66-
configFilePath <-
67-
case configCmdSetScope cmd of
68-
CommandScopeProject -> do
69-
mstackYamlOption <- view $ globalOptsL.to globalStackYaml
70-
mstackYaml <- getProjectConfig mstackYamlOption
71-
case mstackYaml of
72-
PCProject stackYaml -> return stackYaml
73-
PCGlobalProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)
74-
PCNoProject _extraDeps -> throwString "config command used when no project configuration available" -- maybe modify the ~/.stack/config.yaml file instead?
75-
CommandScopeGlobal -> return (configUserConfigPath conf)
233+
case scope of
234+
CommandScopeProject -> do
235+
mstackYamlOption <- view $ globalOptsL.to globalStackYaml
236+
mstackYaml <- getProjectConfig mstackYamlOption
237+
case mstackYaml of
238+
PCProject stackYaml -> return stackYaml
239+
PCGlobalProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)
240+
PCNoProject _extraDeps ->
241+
-- REVIEW: Maybe modify the ~/.stack/config.yaml file instead?
242+
throwString "config command used when no project configuration available"
243+
CommandScopeGlobal -> return (configUserConfigPath conf)
244+
245+
cfgRead :: (HasConfig s, FromJSON a) => CommandScope -> RIO s (Path Abs File, a)
246+
cfgRead scope = do
247+
configFilePath <- cfgLocation scope
248+
249+
-- We don't need to worry about checking for a valid yaml here
250+
liftIO (Yaml.decodeFileEither (toFilePath configFilePath)) >>=
251+
either throwM (return . (configFilePath,))
252+
253+
cfgCmdSet :: (HasConfig env, HasGHCVariant env) => ConfigCmdSet -> RIO env ()
254+
cfgCmdSet cmd = do
255+
configFilePath <- cfgLocation $ configCmdSetScope cmd
76256
-- We don't need to worry about checking for a valid yaml here
77257
rawConfig <- mkRaw <$> liftIO (readFileUtf8 (toFilePath configFilePath))
78258
(config :: Yaml.Object) <- either throwM return (Yaml.decodeEither' . encodeUtf8 $ coerce rawConfig)
@@ -117,15 +297,51 @@ cfgCmdSetOptionName (ConfigCmdSetResolver _) = "resolver"
117297
cfgCmdSetOptionName (ConfigCmdSetSystemGhc _ _) = configMonoidSystemGHCName
118298
cfgCmdSetOptionName (ConfigCmdSetInstallGhc _ _) = configMonoidInstallGHCName
119299

120-
cfgCmdName :: String
300+
cfgCmdName, cfgCmdGetName, cfgCmdSetName, cfgCmdEnvName :: String
301+
cfgCmdDumpProjectName, cfgCmdDumpStackName :: String
121302
cfgCmdName = "config"
122-
123-
cfgCmdSetName :: String
303+
cfgCmdDumpProjectName = "dump-project"
304+
cfgCmdDumpStackName = "dump-stack"
305+
cfgCmdGetName = "get"
124306
cfgCmdSetName = "set"
125-
126-
cfgCmdEnvName :: String
127307
cfgCmdEnvName = "env"
128308

309+
configCmdDumpProjectParser :: OA.Parser ConfigCmdDumpProject
310+
configCmdDumpProjectParser = ConfigCmdDumpProject <$> dumpFormatFlag
311+
312+
configCmdDumpStackParser :: OA.Parser ConfigCmdDumpStack
313+
configCmdDumpStackParser = ConfigCmdDumpStack <$> getDumpStackScope <*> dumpFormatFlag
314+
315+
dumpFormatFlag :: OA.Parser ConfigDumpFormat
316+
dumpFormatFlag =
317+
OA.flag
318+
ConfigDumpYaml
319+
ConfigDumpJson
320+
(OA.long "json" <> OA.help "Dump the configuration as JSON instead of as YAML")
321+
322+
configCmdGetParser :: OA.Parser ConfigCmdGet
323+
configCmdGetParser =
324+
OA.hsubparser $
325+
mconcat
326+
[ OA.command
327+
"resolver"
328+
(OA.info
329+
(OA.pure ConfigCmdGetResolver)
330+
(OA.progDesc "Gets the configured resolver."))
331+
, OA.command
332+
(T.unpack configMonoidSystemGHCName)
333+
(OA.info
334+
(ConfigCmdGetSystemGhc <$> getScopeFlag)
335+
(OA.progDesc
336+
"Gets whether stack should use a system GHC installation or not."))
337+
, OA.command
338+
(T.unpack configMonoidInstallGHCName)
339+
(OA.info
340+
(ConfigCmdGetInstallGhc <$> getScopeFlag)
341+
(OA.progDesc
342+
"Gets whether stack should automatically install GHC when necessary."))
343+
]
344+
129345
configCmdSetParser :: OA.Parser ConfigCmdSet
130346
configCmdSetParser = OA.hsubparser $
131347
mconcat
@@ -140,36 +356,51 @@ configCmdSetParser = OA.hsubparser $
140356
"Change the resolver of the current project."))
141357
, OA.command (T.unpack configMonoidSystemGHCName)
142358
( OA.info
143-
(ConfigCmdSetSystemGhc <$> scopeFlag <*> boolArgument)
359+
(ConfigCmdSetSystemGhc <$> setScopeFlag <*> boolArgument)
144360
(OA.progDesc
145361
"Configure whether Stack should use a system GHC installation \
146362
\or not."))
147363
, OA.command (T.unpack configMonoidInstallGHCName)
148364
( OA.info
149-
(ConfigCmdSetInstallGhc <$> scopeFlag <*> boolArgument)
365+
(ConfigCmdSetInstallGhc <$> setScopeFlag <*> boolArgument)
150366
(OA.progDesc
151367
"Configure whether Stack should automatically install GHC when \
152368
\necessary."))
153369
]
154370

155-
scopeFlag :: OA.Parser CommandScope
156-
scopeFlag = OA.flag
157-
CommandScopeProject
158-
CommandScopeGlobal
159-
( OA.long "global"
160-
<> OA.help
161-
"Modify the user-specific global configuration file ('config.yaml') \
162-
\instead of the project-level configuration file ('stack.yaml')."
163-
)
371+
getScopeFlag, setScopeFlag :: OA.Parser CommandScope
372+
getScopeFlag = scopeFlag "From"
373+
setScopeFlag = scopeFlag "Modify"
374+
375+
getDumpStackScope :: OA.Parser DumpStackScope
376+
getDumpStackScope = OA.option readDumpStackScope
377+
$ OA.long "lens"
378+
<> OA.help "Which configuration to look at, project or global or effective (global with project overrides)."
379+
<> OA.metavar "[project|global|effective]"
380+
381+
scopeFlag :: String -> OA.Parser CommandScope
382+
scopeFlag action =
383+
OA.flag
384+
CommandScopeProject
385+
CommandScopeGlobal
386+
(OA.long "global" <>
387+
OA.help
388+
(action <>
389+
" the user-specific global configuration file ('config.yaml') \
390+
\instead of the project-level configuration file ('stack.yaml')."))
391+
392+
readDumpStackScope :: OA.ReadM DumpStackScope
393+
readDumpStackScope = OA.str >>= \case
394+
("effective" :: String) -> return DumpStackScopeEffective
395+
"project" -> return DumpStackScopeProject
396+
"global" -> return DumpStackScopeGlobal
397+
_ -> OA.readerError "Accepted scopes are 'effective', 'project' and 'global'."
164398

165399
readBool :: OA.ReadM Bool
166-
readBool = do
167-
s <- OA.readerAsk
168-
case s of
400+
readBool = OA.readerAsk >>= \case
169401
"true" -> return True
170402
"false" -> return False
171-
_ -> OA.readerError ("Invalid value " ++ show s ++
172-
": Expected \"true\" or \"false\"")
403+
s -> OA.readerError ("Invalid value " ++ show s ++ ": Expected \"true\" or \"false\"")
173404

174405
boolArgument :: OA.Parser Bool
175406
boolArgument = OA.argument

0 commit comments

Comments
 (0)