diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 0619b35..ab5c3ed 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/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) - => (Int, ListResult) +installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => 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 - liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce) + let vi = getVersionInfo v GHC dls + 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 - liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) + let vi = getVersionInfo v Cabal dls + 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 - let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls - liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) + HLS -> do + let vi = getVersionInfo v HLS dls + 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 - liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) + let vi = getVersionInfo v Stack dls + 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) diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 4a64117..4552eab 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/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 - && m == mods - && n `elem` [Menu.fieldName button | button <- buttons] - -> mode .= ContextPanel + | k == exitKey + && m == mods + && n `elem` [Menu.fieldName button | button <- buttons] + -> 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 () diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs index 343d909..5298343 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs +++ b/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 diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs index bd21287..6712687 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/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 - = if isPathSeparator (T.head i) - then pure $ Right (T.unpack i) - else Left "Not an absolute Path" + readPath = do + mfilepath <- filepathV i + case mfilepath of + 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