Avance Install Functionality. Bug

This commit is contained in:
Luis Morillo 2024-03-01 09:17:25 +01:00 committed by Julian Ospald
parent 06ace5324f
commit e1454d0551
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
3 changed files with 105 additions and 19 deletions

View File

@ -18,7 +18,7 @@ import GHCup.Types.Optics ( getDirs, getPlatformReq )
import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils import GHCup.Utils
import GHCup.OptParse.Common (logGHCPostRm) import GHCup.OptParse.Common (logGHCPostRm)
import GHCup.Prelude ( decUTF8Safe ) import GHCup.Prelude ( decUTF8Safe, runBothE' )
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.Process import GHCup.Prelude.Process
import GHCup.Prompts import GHCup.Prompts
@ -173,12 +173,19 @@ withIOAction action = do
pure (updateList data' as) pure (updateList data' as)
Left err -> throwIO $ userError err 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 ()) -> m (Either String ())
install' (_, ListResult {..}) = do installWithOptions opts (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask 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 = let run =
runResourceT runResourceT
. runE . runE
@ -208,6 +215,7 @@ install' (_, ListResult {..}) = do
, UnsupportedSetupCombo , UnsupportedSetupCombo
, DistroNotFound , DistroNotFound
, NoCompatibleArch , NoCompatibleArch
, InstallSetError
] ]
run (do run (do
@ -216,20 +224,81 @@ install' (_, ListResult {..}) = do
dirs <- lift getDirs dirs <- lift getDirs
case lTool of case lTool of
GHC -> do 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 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 GHCup -> do
let vi = snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) 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 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 >>= \case
VRight (vi, Dirs{..}, Just ce) -> do VRight (vi, Dirs{..}, Just ce) -> do
@ -256,6 +325,9 @@ install' (_, ListResult {..}) = do
VLeft e -> pure $ Left $ prettyHFError e <> "\n" VLeft e -> pure $ Left $ prettyHFError e <> "\n"
<> "Also check the logs in ~/.ghcup/logs" <> "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) set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
=> (Int, ListResult) => (Int, ListResult)

View File

@ -152,6 +152,9 @@ advanceInstallHandler ev = do
&& 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 _ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev
compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState () compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState ()

View File

@ -14,7 +14,18 @@
{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# 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 GHCup.Brick.Widgets.Menu (Menu)
import qualified GHCup.Brick.Widgets.Menu as Menu import qualified GHCup.Brick.Widgets.Menu as Menu