Skip to content

Commit 28f7230

Browse files
sjakobisjakobi
committed
Implement --global flag for suitable stack config set fields
1 parent a11c2c2 commit 28f7230

2 files changed

Lines changed: 68 additions & 60 deletions

File tree

‎.hindent.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
indent-size: 4

‎src/Stack/ConfigCmd.hs‎

Lines changed: 67 additions & 60 deletions
Original file line numberDiff line numberDiff line change
@@ -2,8 +2,7 @@
22
{-# LANGUAGE OverloadedStrings #-}
33
{-# LANGUAGE ScopedTypeVariables #-}
44

5-
-- | Make changes to the stack yaml file
6-
5+
-- | Make changes to project or global configuration.
76
module Stack.ConfigCmd
87
(ConfigCmdSet(..)
98
,configCmdSetParser
@@ -19,8 +18,7 @@ import Control.Monad.Reader (MonadReader, asks)
1918
import Control.Monad.Trans.Control (MonadBaseControl)
2019
import qualified Data.ByteString as S
2120
import qualified Data.HashMap.Strict as HMap
22-
import Data.Map (Map)
23-
import qualified Data.Map.Strict as Map
21+
import Data.Monoid
2422
import Data.Text (Text)
2523
import qualified Data.Text as T
2624
import qualified Data.Yaml.Extra as Yaml
@@ -36,8 +34,22 @@ import Stack.Types.Config
3634

3735
data ConfigCmdSet
3836
= ConfigCmdSetResolver AbstractResolver
39-
| ConfigCmdSetSystemGhc Bool
40-
| ConfigCmdSetInstallGhc Bool
37+
| ConfigCmdSetSystemGhc CommandScope
38+
Bool
39+
| ConfigCmdSetInstallGhc CommandScope
40+
Bool
41+
42+
data CommandScope
43+
= CommandScopeGlobal
44+
-- ^ Apply changes to the global configuration,
45+
-- typically at @~/.stack/config.yaml@.
46+
| CommandScopeProject
47+
-- ^ Apply changes to the project @stack.yaml@.
48+
49+
configCmdSetScope :: ConfigCmdSet -> CommandScope
50+
configCmdSetScope (ConfigCmdSetResolver _) = CommandScopeProject
51+
configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope
52+
configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope
4153

4254
cfgCmdSet :: ( MonadIO m
4355
, MonadBaseControl IO m
@@ -49,25 +61,19 @@ cfgCmdSet :: ( MonadIO m
4961
, MonadLogger m)
5062
=> ConfigCmdSet -> m ()
5163
cfgCmdSet cmd = do
52-
stackYaml <- fmap bcStackYaml (asks getBuildConfig)
53-
let stackYamlFp =
54-
toFilePath stackYaml
64+
configFilePath <-
65+
asks
66+
(toFilePath .
67+
case configCmdSetScope cmd of
68+
CommandScopeProject -> bcStackYaml . getBuildConfig
69+
CommandScopeGlobal -> configUserConfigPath . getConfig)
5570
-- We don't need to worry about checking for a valid yaml here
56-
(projectYamlConfig :: Yaml.Object) <-
57-
liftIO (Yaml.decodeFileEither stackYamlFp) >>=
58-
either throwM return
71+
(config :: Yaml.Object) <-
72+
liftIO (Yaml.decodeFileEither configFilePath) >>= either throwM return
5973
newValue <- cfgCmdSetValue cmd
6074
let cmdKey = cfgCmdSetOptionName cmd
61-
projectYamlConfig' =
62-
HMap.insert
63-
cmdKey
64-
newValue
65-
projectYamlConfig
66-
liftIO
67-
(S.writeFile
68-
stackYamlFp
69-
(Yaml.encode projectYamlConfig'))
70-
return ()
75+
config' = HMap.insert cmdKey newValue config
76+
liftIO (S.writeFile configFilePath (Yaml.encode config'))
7177

7278
cfgCmdSetValue
7379
:: ( MonadIO m
@@ -87,15 +93,15 @@ cfgCmdSetValue (ConfigCmdSetResolver newResolver) = do
8793
snap <- parseSnapName newResolverText
8894
_ <- loadMiniBuildPlan snap
8995
return (Yaml.String newResolverText)
90-
cfgCmdSetValue (ConfigCmdSetSystemGhc bool) = do
96+
cfgCmdSetValue (ConfigCmdSetSystemGhc _ bool) =
9197
return (Yaml.Bool bool)
92-
cfgCmdSetValue (ConfigCmdSetInstallGhc bool) = do
98+
cfgCmdSetValue (ConfigCmdSetInstallGhc _ bool) =
9399
return (Yaml.Bool bool)
94100

95101
cfgCmdSetOptionName :: ConfigCmdSet -> Text
96102
cfgCmdSetOptionName (ConfigCmdSetResolver _) = "resolver"
97-
cfgCmdSetOptionName (ConfigCmdSetSystemGhc _) = configMonoidSystemGHCName
98-
cfgCmdSetOptionName (ConfigCmdSetInstallGhc _) = configMonoidInstallGHCName
103+
cfgCmdSetOptionName (ConfigCmdSetSystemGhc _ _) = configMonoidSystemGHCName
104+
cfgCmdSetOptionName (ConfigCmdSetInstallGhc _ _) = configMonoidInstallGHCName
99105

100106
cfgCmdName :: String
101107
cfgCmdName = "config"
@@ -105,39 +111,40 @@ cfgCmdSetName = "set"
105111

106112
configCmdSetParser :: OA.Parser ConfigCmdSet
107113
configCmdSetParser =
108-
OA.fromM
109-
(do field <-
110-
OA.oneM
111-
(OA.strArgument
112-
(OA.metavar "FIELD VALUE"))
113-
OA.oneM (fieldToValParser field))
114-
where
115-
fieldToValParser :: String -> OA.Parser ConfigCmdSet
116-
fieldToValParser s =
117-
Map.findWithDefault
118-
(error $ concat $
119-
[ "Invalid field "
120-
, show s
121-
, ": Only the following fields are currently implemented:"
122-
] ++
123-
map
124-
(("\n - " ++) . T.unpack)
125-
(Map.keys fieldToValParser'))
126-
(T.pack s)
127-
fieldToValParser'
128-
fieldToValParser' :: Map Text (OA.Parser ConfigCmdSet)
129-
fieldToValParser' =
130-
Map.fromList
131-
[ ( "resolver"
132-
, ConfigCmdSetResolver <$>
133-
OA.argument
134-
readAbstractResolver
135-
OA.idm)
136-
, ( configMonoidSystemGHCName
137-
, ConfigCmdSetSystemGhc <$> boolArgument)
138-
, ( configMonoidInstallGHCName
139-
, ConfigCmdSetInstallGhc <$> boolArgument)
140-
]
114+
OA.hsubparser $
115+
mconcat
116+
[ OA.command
117+
"resolver"
118+
(OA.info
119+
(ConfigCmdSetResolver <$>
120+
OA.argument
121+
readAbstractResolver
122+
(OA.metavar "RESOLVER" <>
123+
OA.help "E.g. \"nightly\" or \"lts-7.2\""))
124+
(OA.progDesc
125+
"Change the resolver of the current project. See https://docs.haskellstack.org/en/stable/yaml_configuration/#resolver for more info."))
126+
, OA.command
127+
(T.unpack configMonoidSystemGHCName)
128+
(OA.info
129+
(ConfigCmdSetSystemGhc <$> scopeFlag <*> boolArgument)
130+
(OA.progDesc
131+
"Configure whether stack should use a system GHC installation or not."))
132+
, OA.command
133+
(T.unpack configMonoidInstallGHCName)
134+
(OA.info
135+
(ConfigCmdSetInstallGhc <$> scopeFlag <*> boolArgument)
136+
(OA.progDesc
137+
"Configure whether stack should automatically install GHC when necessary."))
138+
]
139+
140+
scopeFlag :: OA.Parser CommandScope
141+
scopeFlag =
142+
OA.flag
143+
CommandScopeProject
144+
CommandScopeGlobal
145+
(OA.long "global" <>
146+
OA.help
147+
"Modify the global configuration (typically at \"~/.stack/config.yaml\") instead of the project stack.yaml.")
141148

142149
readBool :: OA.ReadM Bool
143150
readBool = do
@@ -148,4 +155,4 @@ readBool = do
148155
_ -> OA.readerError ("Invalid value " ++ show s ++ ": Expected \"true\" or \"false\"")
149156

150157
boolArgument :: OA.Parser Bool
151-
boolArgument = OA.argument readBool OA.idm
158+
boolArgument = OA.argument readBool (OA.metavar "true/false")

0 commit comments

Comments
 (0)