From e1d4a6fae4ff0a2643d28c023c784434b0acbe97 Mon Sep 17 00:00:00 2001 From: Divam Date: Mon, 4 Nov 2024 18:07:23 +0900 Subject: [PATCH] Allow specifying a custom version in advance install menu --- lib-tui/GHCup/Brick/Actions.hs | 29 ++++++++++--------- lib-tui/GHCup/Brick/Common.hs | 5 +++- .../Brick/Widgets/Menus/AdvanceInstall.hs | 13 ++++++++- 3 files changed, 31 insertions(+), 16 deletions(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 1c911282f..ce1073457 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -193,7 +193,8 @@ installWithOptions opts (_, ListResult {..}) = do shouldForce = opts ^. AdvanceInstall.forceInstallL shouldSet = opts ^. AdvanceInstall.instSetL extraArgs = opts ^. AdvanceInstall.addConfArgsL - v = GHCTargetVersion lCross lVer + v = fromMaybe (GHCTargetVersion lCross lVer) (opts ^. AdvanceInstall.instVersionL) + toolV = _tvVersion v let run = runResourceT . runE @@ -261,14 +262,14 @@ installWithOptions opts (_, ListResult {..}) = do Nothing -> do liftE $ runBothE' - (installCabalBin lVer shouldIsolate shouldForce) - (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer)) + (installCabalBin toolV shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal toolV)) pure (vi, dirs, ce) Just uri -> do liftE $ runBothE' - (withNoVerify $ installCabalBindist (DownloadInfo uri Nothing "" Nothing Nothing Nothing) lVer shouldIsolate shouldForce) - (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer)) + (withNoVerify $ installCabalBindist (DownloadInfo uri Nothing "" Nothing Nothing Nothing) toolV shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal toolV)) pure (vi, dirs, ce) GHCup -> do @@ -280,18 +281,18 @@ installWithOptions opts (_, ListResult {..}) = do Nothing -> do liftE $ runBothE' - (installHLSBin lVer shouldIsolate shouldForce) - (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS lVer SetHLSOnly Nothing)) + (installHLSBin toolV shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS toolV SetHLSOnly Nothing)) pure (vi, dirs, ce) Just uri -> do liftE $ runBothE' (withNoVerify $ installHLSBindist (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing Nothing) - lVer + toolV shouldIsolate shouldForce) - (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS lVer SetHLSOnly Nothing)) + (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS toolV SetHLSOnly Nothing)) pure (vi, dirs, ce) Stack -> do @@ -300,14 +301,14 @@ installWithOptions opts (_, ListResult {..}) = do Nothing -> do liftE $ runBothE' - (installStackBin lVer shouldIsolate shouldForce) - (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer)) + (installStackBin toolV shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setStack toolV)) pure (vi, dirs, ce) Just uri -> do liftE $ runBothE' - (withNoVerify $ installStackBindist (DownloadInfo uri Nothing "" Nothing Nothing Nothing) lVer shouldIsolate shouldForce) - (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer)) + (withNoVerify $ installStackBindist (DownloadInfo uri Nothing "" Nothing Nothing Nothing) toolV shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setStack toolV)) pure (vi, dirs, ce) ) @@ -338,7 +339,7 @@ installWithOptions opts (_, ListResult {..}) = do install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => (Int, ListResult) -> m (Either String ()) -install' = installWithOptions (AdvanceInstall.InstallOptions Nothing False Nothing False []) +install' = installWithOptions (AdvanceInstall.InstallOptions Nothing False Nothing Nothing False []) set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => (Int, ListResult) diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 4ef82c677..fcc392d47 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -48,7 +48,7 @@ module GHCup.Brick.Common ( , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton , CompileGHCButton, CompileHLSButton, CabalProjectEditBox , CabalProjectLocalEditBox, UpdateCabalCheckBox, GitRefEditBox - , BootstrapGhcSelectBox, HadrianGhcSelectBox + , BootstrapGhcSelectBox, HadrianGhcSelectBox, ToolVersionBox ) ) where import GHCup.List ( ListResult ) @@ -133,6 +133,9 @@ pattern BootstrapGhcSelectBox = ResourceId 21 pattern HadrianGhcSelectBox :: ResourceId pattern HadrianGhcSelectBox = ResourceId 22 +pattern ToolVersionBox :: ResourceId +pattern ToolVersionBox = ResourceId 23 + -- | Name data type. Uniquely identifies each widget in the TUI. -- some constructors might end up unused, but still is a good practise -- to have all of them defined, just in case diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs index 198456788..b11d331e4 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs @@ -22,11 +22,13 @@ module GHCup.Brick.Widgets.Menus.AdvanceInstall ( draw, instBindistL, instSetL, + instVersionL, isolateDirL, forceInstallL, addConfArgsL, ) where +import GHCup.Types (GHCTargetVersion(..)) import GHCup.Brick.Widgets.Menu (Menu, MenuKeyBindings) import qualified GHCup.Brick.Widgets.Menu as Menu import GHCup.Brick.Common(Name(..)) @@ -48,6 +50,8 @@ import qualified GHCup.Utils.Parsers as Utils data InstallOptions = InstallOptions { instBindist :: Maybe URI , instSet :: Bool + , instVersion :: Maybe GHCTargetVersion + -- ^ User specified version to override default , isolateDir :: Maybe FilePath , forceInstall :: Bool , addConfArgs :: [T.Text] @@ -56,6 +60,7 @@ data InstallOptions = InstallOptions makeLensesFor [ ("instBindist", "instBindistL") , ("instSet", "instSetL") + , ("instVersion", "instVersionL") , ("isolateDir", "isolateDirL") , ("forceInstall", "forceInstallL") , ("addConfArgs", "addConfArgsL") @@ -67,7 +72,7 @@ type AdvanceInstallMenu = Menu InstallOptions Name create :: MenuKeyBindings -> AdvanceInstallMenu create k = Menu.createMenu AdvanceInstallBox initialState "Advance Install" validator k [ok] fields where - initialState = InstallOptions Nothing False Nothing False [] + initialState = InstallOptions Nothing False Nothing Nothing False [] validator InstallOptions {..} = case (instSet, isolateDir) of (True, Just _) -> Just "Cannot set active when doing an isolated install" _ -> Nothing @@ -84,6 +89,9 @@ create k = Menu.createMenu AdvanceInstallBox initialState "Advance Install" vali filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) filepathValidator = whenEmpty Nothing (bimap T.pack Just . Utils.absolutePathParser . T.unpack) + toolVersionValidator :: T.Text -> Either Menu.ErrorMessage (Maybe GHCTargetVersion) + toolVersionValidator = whenEmpty Nothing (bimap T.pack Just . Utils.ghcVersionEither . T.unpack) + additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] additionalValidator = Right . T.split isSpace @@ -94,6 +102,9 @@ create k = Menu.createMenu AdvanceInstallBox initialState "Advance Install" vali , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) instSetL & Menu.fieldLabelL .~ "set" & Menu.fieldHelpMsgL .~ "Set as active version after install" + , Menu.createEditableField (Common.MenuElement Common.ToolVersionBox) toolVersionValidator instVersionL + & Menu.fieldLabelL .~ "version" + & Menu.fieldHelpMsgL .~ "Specify a custom version" , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathValidator isolateDirL & Menu.fieldLabelL .~ "isolated" & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one"