Advance Install menu implements functionality.

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
@@ -35,6 +46,8 @@ import Data.Bifunctor (Bifunctor(..))
 import Data.Function ((&))
 import Optics ((.~))
 import Data.Char (isSpace)
+import System.FilePath (isValid, isAbsolute, normalise)
+import GHCup.Prelude (stripNewlineEnd)
 
 data InstallOptions = InstallOptions
   { instBindist  :: Maybe URI
@@ -71,9 +84,14 @@ create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields
     filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath)
     filepathValidator i = 
       case not $ emptyEditor i of
-        True  -> Right . Just . T.unpack $ i
+        True  -> absolutePathParser (T.unpack i)
         False -> Right Nothing
 
+    absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath)
+    absolutePathParser f = case isValid f && isAbsolute f of
+                  True -> Right . Just . stripNewlineEnd . normalise $ f
+                  False -> Left "Please enter a valid absolute filepath."
+
     additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
     additionalValidator = Right . T.split isSpace
 

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

@@ -36,9 +36,10 @@ import Data.Function ((&))
 import Optics ((.~))
 import Data.Char (isSpace)
 import Data.Versions (Version, version)
-import System.FilePath (isPathSeparator)
+import System.FilePath (isPathSeparator, isValid, isAbsolute, normalise)
 import Control.Applicative (Alternative((<|>)))
 import Text.Read (readEither)
+import GHCup.Prelude (stripNewlineEnd)
 
 data CompileGHCOptions = CompileGHCOptions
   { _bootstrapGhc :: Either Version FilePath
@@ -84,10 +85,11 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
       case not $ emptyEditor i of
         True  -> 
           let readVersion = bimap (const "Not a valid version") Left (version (T.init i)) -- Brick adds \n at the end, hence T.init
-              readPath
+              readPath = do 
-                 = if isPathSeparator (T.head i) 
+                mfilepath <- filepathV i
-                    then pure $ Right (T.unpack i)
+                case mfilepath of
-                    else Left "Not an absolute Path"
+                  Nothing -> Left "Invalid Empty value"
+                  Just f  -> Right (Right f)
            in if T.any isPathSeparator i 
                 then readPath
                 else readVersion
@@ -113,7 +115,15 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
           in first T.pack $ x <|> y
 
     filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath)
-    filepathV = whenEmpty Nothing (Right . Just . T.unpack)
+    filepathV i = 
+      case not $ emptyEditor i of
+        True  -> absolutePathParser (T.unpack i)
+        False -> Right Nothing
+
+    absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath)
+    absolutePathParser f = case isValid f && isAbsolute f of
+                  True -> Right . Just . stripNewlineEnd . normalise $ f
+                  False -> Left "Please enter a valid absolute filepath."
 
     additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
     additionalValidator = Right . T.split isSpace