diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index d3d96dc..7d48cb3 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -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 () diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 350659f..b4eb779 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 |] -- 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 |] 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