Avance Install Functionality. Bug

lib-tui/GHCup/Brick/Actions.hs

@@ -18,7 +18,7 @@ import           GHCup.Types.Optics ( getDirs, getPlatformReq )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
 import           GHCup.OptParse.Common (logGHCPostRm)
-import           GHCup.Prelude ( decUTF8Safe )
+import           GHCup.Prelude ( decUTF8Safe, runBothE' )
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.Process
 import           GHCup.Prompts
@@ -173,12 +173,19 @@ withIOAction action = do
             pure (updateList data' as)
           Left err -> throwIO $ userError err
 
-install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
+installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
-         => (Int, ListResult)
+         => AdvanceInstall.InstallOptions
+         -> (Int, ListResult)
          -> m (Either String ())
-install' (_, ListResult {..}) = do
+installWithOptions opts (_, ListResult {..}) = do
   AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-
+  let 
+    misolated = opts ^. AdvanceInstall.isolateDirL
+    shouldIsolate = maybe GHCupInternal IsolateDir (opts ^. AdvanceInstall.isolateDirL)
+    shouldForce   = opts ^. AdvanceInstall.forceInstallL
+    shouldSet     = opts ^. AdvanceInstall.instSetL
+    extraArgs     = opts ^. AdvanceInstall.addConfArgsL
+    v = GHCTargetVersion lCross lVer
   let run =
         runResourceT
           . runE
@@ -208,6 +215,7 @@ install' (_, ListResult {..}) = do
               , UnsupportedSetupCombo
               , DistroNotFound
               , NoCompatibleArch
+              , InstallSetError
               ]
 
   run (do
@@ -216,20 +224,81 @@ install' (_, ListResult {..}) = do
       dirs <- lift getDirs
       case lTool of
         GHC   -> do
-          let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls
+          let vi = getVersionInfo v GHC dls
-          liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce)
+          case opts ^. AdvanceInstall.instBindistL of
+            Nothing -> do
+              liftE $
+                runBothE' 
+                  (installGHCBin v shouldIsolate shouldForce  extraArgs)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing))
+              pure (vi, dirs, ce) 
+            Just uri -> do
+              liftE $
+                runBothE' 
+                  (installGHCBindist
+                      (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) 
+                      v
+                      shouldIsolate
+                      shouldForce
+                      extraArgs)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing))
+              pure (vi, dirs, ce)
+
         Cabal -> do
-          let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls
+          let vi = getVersionInfo v Cabal dls
-          liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
+          case opts ^. AdvanceInstall.instBindistL of
+            Nothing -> do
+              liftE $ 
+                runBothE' 
+                  (installCabalBin lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer))
+              pure (vi, dirs, ce)
+            Just uri -> do
+              liftE $ 
+                runBothE' 
+                  (installCabalBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer))
+              pure (vi, dirs, ce)
+
         GHCup -> do
           let vi = snd <$> getLatest dls GHCup
           liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
-        HLS   -> do
+        HLS   -> do          
-          let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls
+          let vi = getVersionInfo v HLS dls
-          liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
+          case opts ^. AdvanceInstall.instBindistL of
+            Nothing -> do
+              liftE $ 
+                runBothE' 
+                  (installHLSBin lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS lVer SetHLSOnly Nothing))
+              pure (vi, dirs, ce) 
+            Just uri -> do
+              liftE $ 
+                runBothE'                 
+                  (installHLSBindist 
+                    (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing)
+                    lVer
+                    shouldIsolate
+                    shouldForce)
+                  (when (shouldSet && isNothing misolated)  (liftE $ void $ setHLS lVer SetHLSOnly Nothing))
+              pure (vi, dirs, ce)
+
         Stack -> do
-          let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls
+          let vi = getVersionInfo v Stack dls
-          liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
+          case opts ^. AdvanceInstall.instBindistL of
+            Nothing -> do
+              liftE $
+                runBothE' 
+                  (installStackBin lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer))
+              pure (vi, dirs, ce)
+            Just uri -> do
+              liftE $
+                runBothE' 
+                  (installStackBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer))
+              pure (vi, dirs, ce)
+
     )
     >>= \case
           VRight (vi, Dirs{..}, Just ce) -> do
@@ -256,6 +325,9 @@ install' (_, ListResult {..}) = do
           VLeft e -> pure $ Left $ prettyHFError e <> "\n"
             <> "Also check the logs in ~/.ghcup/logs"
 
+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 [])
 
 set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
      => (Int, ListResult)

lib-tui/GHCup/Brick/App.hs

@@ -148,10 +148,13 @@ advanceInstallHandler ev = do
   case (ev, focusedElement) of
     (_ , Nothing) -> pure ()
     (VtyEvent (Vty.EvKey k m), Just n)
-      | k == exitKey
+        | k == exitKey
-          && m == mods
+            && m == mods
-          && n `elem` [Menu.fieldName button | button <- buttons]
+            && n `elem` [Menu.fieldName button | button <- buttons]
-      -> mode .= ContextPanel
+        -> mode .= ContextPanel
+    (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do
+        let iopts = ctx ^. Menu.menuStateL
+        Actions.withIOAction $ Actions.installWithOptions iopts
     _ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev
 
 compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState ()

lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs

@@ -14,7 +14,18 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 
-module GHCup.Brick.Widgets.Menus.AdvanceInstall (InstallOptions, AdvanceInstallMenu, create, handler, draw) where
+module GHCup.Brick.Widgets.Menus.AdvanceInstall (
+  InstallOptions (..),
+  AdvanceInstallMenu,
+  create,
+  handler,
+  draw,
+  instBindistL,
+  instSetL,
+  isolateDirL,
+  forceInstallL,
+  addConfArgsL,
+) where
 
 import GHCup.Brick.Widgets.Menu (Menu)
 import qualified GHCup.Brick.Widgets.Menu as Menu