From 1cfff674b790ecf028da34737cd2be2522466d01 Mon Sep 17 00:00:00 2001 From: vglfr Date: Tue, 3 Aug 2021 09:09:47 +0300 Subject: [PATCH] Implement config CLI MVP --- app/ghcup/Main.hs | 84 +++++++++++++++++++++++++++++++++++++++++ ghcup.cabal | 1 + lib/GHCup/Types/JSON.hs | 3 ++ 3 files changed, 88 insertions(+) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 4083923..234400f 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -78,6 +78,8 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as E +import qualified Data.Yaml as Y +import qualified Data.Yaml.Pretty as YP import qualified Text.Megaparsec as MP import qualified Text.Megaparsec.Char as MPC @@ -105,6 +107,7 @@ data Command | Rm (Either RmCommand RmOptions) | DInfo | Compile CompileCommand + | Config ConfigCommand | Whereis WhereisOptions WhereisCommand | Upgrade UpgradeOpts Bool | ToolRequirements @@ -173,6 +176,8 @@ data RmOptions = RmOptions data CompileCommand = CompileGHC GHCCompileOptions +data ConfigCommand = ShowConfig | SetConfig String String | InitConfig + data GHCCompileOptions = GHCCompileOptions { targetGhc :: Either Version GitBranch , bootstrapGhc :: Either Version FilePath @@ -408,6 +413,12 @@ com = <> footerDoc (Just $ text changeLogFooter) ) ) + <> command + "config" + ( Config + <$> info (configP <**> helper) + (progDesc "Show or set config" <> footerDoc (Just $ text configFooter)) + ) <> commandGroup "Other commands:" <> hidden ) @@ -482,6 +493,17 @@ Examples: ghcup prefetch ghc 8.10.5 ghcup --offline install ghc 8.10.5|] +configFooter :: String +configFooter = [s|Examples: + +# show current config +ghcup config + +# initialize config +ghcup config init + +# set configuration pair +ghcup config |] installCabalFooter :: String installCabalFooter = [s|Discussion: @@ -786,6 +808,19 @@ Examples: # build cross compiler ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|] +configP :: Parser ConfigCommand +configP = subparser + ( command "init" initP + <> command "set" setP -- [set] KEY VALUE at help lhs + <> command "show" showP + ) + <|> argsP -- add show for a single option + <|> pure ShowConfig + where + initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml") + showP = info (pure ShowConfig) (progDesc "Show current config (default)") + setP = info argsP (progDesc "Set config KEY to VALUE") + argsP = SetConfig <$> argument str (metavar "KEY") <*> argument str (metavar "VALUE") whereisP :: Parser WhereisCommand whereisP = subparser @@ -1258,6 +1293,27 @@ toSettings options = do , bShowAllTools = fromMaybe bShowAllTools kShowAllTools } +updateSettings :: UTF8.ByteString -> Settings -> IO Settings +updateSettings config settings = do + settings' <- runE @'[JSONError] $ lE' JSONDecodeError . first show . Y.decodeEither' $ config + + case settings' of + VRight r -> pure $ mergeConf r settings + VLeft (V (JSONDecodeError e)) -> do + B.hPut stderr ("Error decoding config: " <> (E.encodeUtf8 . T.pack . show $ e)) + die "" + _ -> die "Unexpected error!" + where + mergeConf :: UserSettings -> Settings -> Settings + mergeConf UserSettings{..} Settings{..} = + let cache' = fromMaybe cache uCache + noVerify' = fromMaybe noVerify uNoVerify + keepDirs' = fromMaybe keepDirs uKeepDirs + downloader' = fromMaybe downloader uDownloader + verbose' = fromMaybe verbose uVerbose + urlSource' = fromMaybe urlSource uUrlSource + noNetwork' = fromMaybe noNetwork uNoNetwork + in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' upgradeOptsP :: Parser UpgradeOpts upgradeOptsP = @@ -1292,6 +1348,12 @@ describe_result = $( LitE . StringL <$> ) ) +formatConfig :: Settings -> KeyBindings -> String +formatConfig settings keybindings = unlines [formatSettings, formatKeybindings] + where + formatKeybindings = unlines . ("key-bindings:":) . map (" "++) . lines . UTF8.toString . YP.encodePretty yamlConfig $ keybindings + formatSettings = UTF8.toString . YP.encodePretty yamlConfig $ settings + yamlConfig = YP.setConfCompare compare YP.defConfig main :: IO () main = do @@ -1990,6 +2052,28 @@ Make sure to clean up #{tmpdir} afterwards.|]) runLogger $ $(logError) $ T.pack $ prettyShow e pure $ ExitFailure 9 + Config InitConfig -> do + path <- getConfigFilePath + writeFile path $ formatConfig settings keybindings + runLogger $ $(logDebug) [i|"config.yaml initialized at #{path}|] + pure ExitSuccess + + Config ShowConfig -> do + putStrLn $ formatConfig settings keybindings + pure ExitSuccess + + Config (SetConfig k v) -> do + case v of + "" -> die "Empty values are not allowed." + _ -> do + settings' <- updateSettings [i|#{k}: #{v}\n|] settings + runLogger $ $(logDebug) $ T.pack $ show settings' + + path <- getConfigFilePath + writeFile path $ formatConfig settings' keybindings + + pure ExitSuccess + Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) -> runLeanWhereIs (do loc <- liftE $ whereIsTool tool v diff --git a/ghcup.cabal b/ghcup.cabal index be8bdf4..c5b9099 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -226,6 +226,7 @@ executable ghcup , uri-bytestring ^>=0.3.2.2 , utf8-string ^>=1.0 , versions >=4.0.1 && <5.1 + , yaml ^>=0.11.4.0 if flag(internal-downloader) cpp-options: -DINTERNAL_DOWNLOADER diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 8ddfb8f..0d97f69 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -316,3 +316,6 @@ deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings + +deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings +deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key