Don't implicitly smuggle in config options

Fixes #775
This commit is contained in:
Julian Ospald 2023-02-09 00:04:36 +08:00
parent d3a1115b99
commit 20f0505120
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
2 changed files with 41 additions and 23 deletions

View File

@ -59,7 +59,7 @@ data ConfigCommand
--[ Parsers ]--
---------------
configP :: Parser ConfigCommand
configP = subparser
( command "init" initP
@ -120,21 +120,38 @@ formatConfig :: UserSettings -> String
formatConfig = UTF8.toString . Y.encode
updateSettings :: UserSettings -> Settings -> Settings
updateSettings UserSettings{..} Settings{..} =
let cache' = fromMaybe cache uCache
metaCache' = fromMaybe metaCache uMetaCache
metaMode' = fromMaybe metaMode uMetaMode
noVerify' = fromMaybe noVerify uNoVerify
keepDirs' = fromMaybe keepDirs uKeepDirs
downloader' = fromMaybe downloader uDownloader
verbose' = fromMaybe verbose uVerbose
urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting
platformOverride' = uPlatformOverride <|> platformOverride
mirrors' = fromMaybe mirrors uMirrors
in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' mirrors'
updateSettings :: UserSettings -> UserSettings -> UserSettings
updateSettings usl usr =
let cache' = uCache usl <|> uCache usr
metaCache' = uMetaCache usl <|> uMetaCache usr
metaMode' = uMetaMode usl <|> uMetaMode usr
noVerify' = uNoVerify usl <|> uNoVerify usr
verbose' = uVerbose usl <|> uVerbose usr
keepDirs' = uKeepDirs usl <|> uKeepDirs usr
downloader' = uDownloader usl <|> uDownloader usr
urlSource' = uUrlSource usl <|> uUrlSource usr
noNetwork' = uNoNetwork usl <|> uNoNetwork usr
gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
mirrors' = uMirrors usl <|> uMirrors usr
in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'
where
updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
updateKeyBindings Nothing Nothing = Nothing
updateKeyBindings (Just kbl) Nothing = Just kbl
updateKeyBindings Nothing (Just kbr) = Just kbr
updateKeyBindings (Just kbl) (Just kbr) =
Just $ UserKeyBindings {
kUp = kUp kbl <|> kUp kbr
, kDown = kDown kbl <|> kDown kbr
, kQuit = kQuit kbl <|> kQuit kbr
, kInstall = kInstall kbl <|> kInstall kbr
, kUninstall = kUninstall kbl <|> kUninstall kbr
, kSet = kSet kbl <|> kSet kbr
, kChangelog = kChangelog kbl <|> kChangelog kbr
, kShowAll = kShowAll kbl <|> kShowAll kbr
, kShowAllTools = kShowAllTools kbl <|> kShowAllTools kbr
}
@ -151,10 +168,11 @@ config :: forall m. ( Monad m
)
=> ConfigCommand
-> Settings
-> UserSettings
-> KeyBindings
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
config configCommand settings keybindings runLogger = case configCommand of
config configCommand settings userConf keybindings runLogger = case configCommand of
InitConfig -> do
path <- getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
@ -203,9 +221,9 @@ config configCommand settings keybindings runLogger = case configCommand of
where
doConfig :: MonadIO m => UserSettings -> m ()
doConfig usersettings = do
let settings' = updateSettings usersettings settings
let settings' = updateSettings usersettings userConf
path <- liftIO getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
liftIO $ writeFile path $ formatConfig $ settings'
runLogger $ logDebug $ T.pack $ show settings'
pure ()

View File

@ -63,7 +63,7 @@ import qualified GHCup.Types as Types
toSettings :: Options -> IO (Settings, KeyBindings)
toSettings :: Options -> IO (Settings, KeyBindings, UserSettings)
toSettings options = do
noColor <- isJust <$> lookupEnv "NO_COLOR"
userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
@ -73,7 +73,7 @@ toSettings options = do
pure defaultUserSettings
_ -> do
die "Unexpected error!"
pure $ mergeConf options userConf noColor
pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor
where
mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings)
mergeConf Options{..} UserSettings{..} noColor =
@ -176,7 +176,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
-- create ~/.ghcup dir
ensureDirectories dirs
(settings, keybindings) <- toSettings opt
(settings, keybindings, userConf) <- toSettings opt
-- logger interpreter
logfile <- runReaderT initGHCupFileLogging dirs
@ -303,7 +303,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
Rm rmCommand -> rm rmCommand runAppState runLogger
DInfo -> dinfo runAppState runLogger
Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger
Config configCommand -> config configCommand settings keybindings runLogger
Config configCommand -> config configCommand settings userConf keybindings runLogger
Whereis whereisOptions
whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger