Allow specifying a custom version in advance install menu

haskell · Nov 12, 2024 · 4a17087 · 4a17087
1 parent a32a559
commit 4a17087
Show file tree

Hide file tree

Showing 3 changed files with 31 additions and 16 deletions.
diff --git 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) lVer shouldIsolate shouldForce)
-                  (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer))
+                  (withNoVerify $ installCabalBindist (DownloadInfo uri 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)
-                    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) lVer shouldIsolate shouldForce)
-                  (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer))
+                  (withNoVerify $ installStackBindist (DownloadInfo uri 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
@@ -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 )
@@ -132,6 +132,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
@@ -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"