hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Make upgrading ghcup in TUI more pleasant

Browse Source
This commit is contained in:
Julian Ospald 2021-10-30 12:52:11 +02:00
parent 7bb67dd4c6
commit 360daf2a09
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
2 changed files with 31 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
app/ghcup/BrickMain.hs
View File

@ -10,6 +10,7 @@ module BrickMain where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Types.Optics ( getDirs )
import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.Logger import GHCup.Utils.Logger
@ -40,6 +41,8 @@ import Data.Vector ( Vector
import Data.Versions hiding ( str ) import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Directory ( canonicalizePath )
import System.FilePath
import System.Exit import System.Exit
import System.IO.Unsafe import System.IO.Unsafe
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
@ -48,6 +51,8 @@ import URI.ByteString
import qualified Data.Text as T import qualified Data.Text as T
import qualified Graphics.Vty as Vty import qualified Graphics.Vty as Vty
import qualified Data.Vector as V import qualified Data.Vector as V
import System.Environment (getExecutablePath)
import qualified System.Posix.Process as SPP
hiddenTools :: [Tool] hiddenTools :: [Tool]
@ -432,27 +437,42 @@ install' _ (_, ListResult {..}) = do
] ]
run (do run (do
ce <- liftIO $ fmap (either (const Nothing) Just) $
try @_ @SomeException $ getExecutablePath >>= canonicalizePath
dirs <- lift getDirs
case lTool of case lTool of
GHC -> do GHC -> do
let vi = getVersionInfo lVer GHC dls let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer Nothing False $> vi liftE $ installGHCBin lVer Nothing False $> (vi, dirs, ce)
Cabal -> do Cabal -> do
let vi = getVersionInfo lVer Cabal dls let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer Nothing False $> vi liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce)
GHCup -> do GHCup -> do
let vi = snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> vi liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce)
HLS -> do HLS -> do
let vi = getVersionInfo lVer HLS dls let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer Nothing False $> vi liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce)
Stack -> do Stack -> do
let vi = getVersionInfo lVer Stack dls let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer Nothing False $> vi liftE $ installStackBin lVer Nothing False $> (vi, dirs, ce)
) )
>>= \case >>= \case
VRight vi -> do VRight (vi, Dirs{..}, Just ce) -> do
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
logInfo msg case lTool of
GHCup -> do
up <- liftIO $ fmap (either (const Nothing) Just)
$ try @_ @SomeException $ canonicalizePath (binDir </> "ghcup" <.> exeExt)
when ((normalise <$> up) == Just (normalise ce)) $
-- TODO: track cli arguments of previous invocation
liftIO $ SPP.executeFile ce False ["tui"] Nothing
logInfo "Please restart 'ghcup' for the changes to take effect"
_ -> pure ()
pure $ Right ()
VRight (vi, _, _) -> do
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
logInfo "Please restart 'ghcup' for the changes to take effect"
pure $ Right () pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right () VLeft (V NoUpdate) -> pure $ Right ()
@ -605,4 +625,3 @@ getAppData mgi = runExceptT $ do
flip runReaderT settings $ do flip runReaderT settings $ do
lV <- listVersions Nothing Nothing lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV) pure $ BrickData (reverse lV)

3
ghcup.cabal
View File

@ -224,6 +224,7 @@ executable ghcup
, cabal-plan ^>=0.7.2 , cabal-plan ^>=0.7.2
, containers ^>=0.6 , containers ^>=0.6
, deepseq ^>=1.4 , deepseq ^>=1.4
, directory ^>=1.3.6.0
, filepath ^>=1.4.2.1 , filepath ^>=1.4.2.1
, ghcup , ghcup
, haskus-utils-variant >=3.0 && <3.2 , haskus-utils-variant >=3.0 && <3.2
@ -252,11 +253,13 @@ executable ghcup
build-depends: build-depends:
, brick ^>=0.64 , brick ^>=0.64
, transformers ^>=0.5 , transformers ^>=0.5
, unix ^>=2.7
, vector ^>=0.12 , vector ^>=0.12
, vty >=5.28.2 && <5.34 , vty >=5.28.2 && <5.34
if os(windows) if os(windows)
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS
if flag(no-exe) if flag(no-exe)
buildable: False buildable: False