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

Merge branch 'reenable-upgrade'

Browse Source
This commit is contained in:
Julian Ospald 2022-05-11 16:20:28 +02:00
commit 0f052c3465
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
8 changed files with 73 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
app/ghcup/BrickMain.hs
View File

@ -437,6 +437,7 @@ install' _ (_, ListResult {..}) = do
, TarDirDoesNotExist , TarDirDoesNotExist
, FileAlreadyExistsError , FileAlreadyExistsError
, ProcessError , ProcessError
, GHCupShadowed
] ]
run (do run (do
@ -452,7 +453,7 @@ install' _ (_, ListResult {..}) = do
liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce) 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, dirs, ce) liftE $ upgradeGHCup Nothing False 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, dirs, ce) liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce)

6
app/ghcup/GHCup/OptParse.hs
View File

@ -96,7 +96,7 @@ data Command
| Config ConfigCommand | Config ConfigCommand
| Whereis WhereisOptions WhereisCommand | Whereis WhereisOptions WhereisCommand
#ifndef DISABLE_UPGRADE #ifndef DISABLE_UPGRADE
| Upgrade UpgradeOpts Bool | Upgrade UpgradeOpts Bool Bool
#endif #endif
| ToolRequirements ToolReqOpts | ToolRequirements ToolReqOpts
| ChangeLog ChangeLogOptions | ChangeLog ChangeLogOptions
@ -222,18 +222,18 @@ com =
(info (List <$> listOpts <**> helper) (info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools") (progDesc "Show available GHCs and other tools")
) )
#ifndef DISABLE_UPGRADE
<> command <> command
"upgrade" "upgrade"
(info (info
( (Upgrade <$> upgradeOptsP <*> switch ( (Upgrade <$> upgradeOptsP <*> switch
(short 'f' <> long "force" <> help "Force update") (short 'f' <> long "force" <> help "Force update")
<*> switch
(long "fail-if-shadowed" <> help "Fails after upgrading if the upgraded ghcup binary is shadowed by something else in PATH (useful for CI)")
) )
<**> helper <**> helper
) )
(progDesc "Upgrade ghcup") (progDesc "Upgrade ghcup")
) )
#endif
<> command <> command
"compile" "compile"
( Compile ( Compile

13
app/ghcup/GHCup/OptParse/Upgrade.hs
View File

@ -59,15 +59,16 @@ data UpgradeOpts = UpgradeInplace
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
upgradeOptsP :: Parser UpgradeOpts upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP = upgradeOptsP =
flag' flag'
UpgradeInplace UpgradeInplace
(short 'i' <> long "inplace" <> help (short 'i' <> long "inplace" <> help
"Upgrade ghcup in-place (wherever it's at)" "Upgrade ghcup in-place"
) )
<|> ( UpgradeAt <|>
( UpgradeAt
<$> option <$> option
str str
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help (short 't' <> long "target" <> metavar "TARGET_DIR" <> help
@ -92,6 +93,7 @@ type UpgradeEffects = '[ DigestError
, FileDoesNotExistError , FileDoesNotExistError
, CopyError , CopyError
, DownloadFailed , DownloadFailed
, GHCupShadowed
] ]
@ -120,18 +122,19 @@ upgrade :: ( Monad m
) )
=> UpgradeOpts => UpgradeOpts
-> Bool -> Bool
-> Bool
-> Dirs -> Dirs
-> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a)) -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a))
-> (ReaderT LeanAppState m () -> m ()) -> (ReaderT LeanAppState m () -> m ())
-> m ExitCode -> m ExitCode
upgrade uOpts force' Dirs{..} runAppState runLogger = do upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
target <- case uOpts of target <- case uOpts of
UpgradeInplace -> Just <$> liftIO getExecutablePath UpgradeInplace -> Just <$> liftIO getExecutablePath
(UpgradeAt p) -> pure $ Just p (UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt)) UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
runUpgrade runAppState (do runUpgrade runAppState (do
v' <- liftE $ upgradeGHCup target force' v' <- liftE $ upgradeGHCup target force' fatal
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (v', dls) pure (v', dls)
) >>= \case ) >>= \case

46
app/ghcup/Main.hs
View File

@ -141,9 +141,7 @@ main = do
) )
let listCommands = infoOption let listCommands = infoOption
("install set rm install-cabal list" ("install set rm install-cabal list"
#ifndef DISABLE_UPGRADE
<> " upgrade" <> " upgrade"
#endif
<> " compile debug-info tool-requirements changelog" <> " compile debug-info tool-requirements changelog"
) )
( long "list-commands" ( long "list-commands"
@ -245,14 +243,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
alreadyInstalling' <- alreadyInstalling optCommand newTool alreadyInstalling' <- alreadyInstalling optCommand newTool
when (not alreadyInstalling') $ when (not alreadyInstalling') $
case t of case t of
#ifdef DISABLE_UPGRADE
GHCup -> pure ()
#else
GHCup -> runLogger $ GHCup -> runLogger $
logWarn ("New GHCup version available: " logWarn ("New GHCup version available: "
<> prettyVer l <> prettyVer l
<> ". To upgrade, run 'ghcup upgrade'") <> ". To upgrade, run 'ghcup upgrade'")
#endif
_ -> runLogger $ _ -> runLogger $
logWarn ("New " logWarn ("New "
<> T.pack (prettyShow t) <> T.pack (prettyShow t)
@ -296,26 +290,24 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
s' <- appState s' <- appState
liftIO $ brickMain s' >> pure ExitSuccess liftIO $ brickMain s' >> pure ExitSuccess
#endif #endif
Install installCommand -> install installCommand settings appState runLogger Install installCommand -> install installCommand settings appState runLogger
InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger
Set setCommand -> set setCommand runAppState runLeanAppState runLogger Set setCommand -> set setCommand runAppState runLeanAppState runLogger
UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger
List lo -> list lo no_color runAppState List lo -> list lo no_color runAppState
Rm rmCommand -> rm rmCommand runAppState runLogger Rm rmCommand -> rm rmCommand runAppState runLogger
DInfo -> dinfo runAppState runLogger DInfo -> dinfo runAppState runLogger
Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger
Config configCommand -> config configCommand settings keybindings runLogger Config configCommand -> config configCommand settings keybindings runLogger
Whereis whereisOptions Whereis whereisOptions
whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
#ifndef DISABLE_UPGRADE Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger
Upgrade uOpts force' -> upgrade uOpts force' dirs runAppState runLogger ToolRequirements topts -> toolRequirements topts runAppState runLogger
#endif ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger
ToolRequirements topts -> toolRequirements topts runAppState runLogger Nuke -> nuke appState runLogger
ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger
Nuke -> nuke appState runLogger GC gcOpts -> gc gcOpts runAppState runLogger
Prefetch pfCom -> prefetch pfCom runAppState runLogger Run runCommand -> run runCommand appState leanAppstate runLogger
GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand appState leanAppstate runLogger
case res of case res of
ExitSuccess -> pure () ExitSuccess -> pure ()
@ -353,9 +345,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver })) alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
#ifndef DISABLE_UPGRADE alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True
alreadyInstalling (Upgrade _ _) (GHCup, _) = pure True
#endif
alreadyInstalling _ _ = pure False alreadyInstalling _ _ = pure False
cmp' :: ( HasLog env cmp' :: ( HasLog env

7
docs/guide.md
View File

@ -57,6 +57,13 @@ as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
and make sure your bashrc sources the startup script and make sure your bashrc sources the startup script
(`/usr/share/bash-completion/bash_completion` on some distros). (`/usr/share/bash-completion/bash_completion` on some distros).
## Portability
`ghcup` is very portable. There are a few exceptions though:
1. `ghcup tui` is only available on non-windows platforms
2. legacy subcommands `ghcup install` (without a tool identifier) and `ghcup install-cabal` may be removed in the future
# Configuration # Configuration
A configuration file can be put in `~/.ghcup/config.yaml`. The default config file A configuration file can be put in `~/.ghcup/config.yaml`. The default config file

13
ghcup.cabal
View File

@ -48,13 +48,6 @@ flag no-exe
default: False default: False
manual: True manual: True
flag disable-upgrade
description:
Disable upgrade functionality. This is mainly to support brew packagers.
default: False
manual: True
library library
exposed-modules: exposed-modules:
GHCup GHCup
@ -204,6 +197,7 @@ executable ghcup
GHCup.OptParse.Set GHCup.OptParse.Set
GHCup.OptParse.ToolRequirements GHCup.OptParse.ToolRequirements
GHCup.OptParse.UnSet GHCup.OptParse.UnSet
GHCup.OptParse.Upgrade
GHCup.OptParse.Whereis GHCup.OptParse.Whereis
hs-source-dirs: app/ghcup hs-source-dirs: app/ghcup
@ -277,11 +271,6 @@ executable ghcup
if flag(no-exe) if flag(no-exe)
buildable: False buildable: False
if flag(disable-upgrade)
cpp-options: -DDISABLE_UPGRADE
else
other-modules: GHCup.OptParse.Upgrade
test-suite ghcup-test test-suite ghcup-test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0

25
lib/GHCup.hs
View File

@ -2587,6 +2587,7 @@ upgradeGHCup :: ( MonadMask m
=> Maybe FilePath -- ^ full file destination to write ghcup into => Maybe FilePath -- ^ full file destination to write ghcup into
-> Bool -- ^ whether to force update regardless -> Bool -- ^ whether to force update regardless
-- of currently installed version -- of currently installed version
-> Bool -- ^ whether to throw an error if ghcup is shadowed
-> Excepts -> Excepts
'[ CopyError '[ CopyError
, DigestError , DigestError
@ -2595,10 +2596,11 @@ upgradeGHCup :: ( MonadMask m
, DownloadFailed , DownloadFailed
, NoDownload , NoDownload
, NoUpdate , NoUpdate
, GHCupShadowed
] ]
m m
Version Version
upgradeGHCup mtarget force' = do upgradeGHCup mtarget force' fatal = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@ -2625,15 +2627,18 @@ upgradeGHCup mtarget force' = do
lift $ logWarn $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup." lift $ logWarn $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup."
liftIO (isShadowed destFile) >>= \case liftIO (isShadowed destFile) >>= \case
Nothing -> pure () Nothing -> pure ()
Just pa -> lift $ logWarn $ "ghcup is shadowed by " Just pa
<> T.pack pa | fatal -> throwE (GHCupShadowed pa destFile latestVer)
<> ". The upgrade will not be in effect, unless you remove " | otherwise ->
<> T.pack pa lift $ logWarn $ "ghcup is shadowed by "
<> " or make sure " <> T.pack pa
<> T.pack destDir <> ". The upgrade will not be in effect, unless you remove "
<> " comes before " <> T.pack pa
<> T.pack (takeFileName pa) <> " or make sure "
<> " in PATH." <> T.pack destDir
<> " comes before "
<> T.pack (takeDirectory pa)
<> " in PATH."
pure latestVer pure latestVer

19
lib/GHCup/Errors.hs
View File

@ -27,6 +27,7 @@ import Data.CaseInsensitive ( CI )
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import Haskus.Utils.Variant import Haskus.Utils.Variant
import System.FilePath
import Text.PrettyPrint hiding ( (<>) ) import Text.PrettyPrint hiding ( (<>) )
import Text.PrettyPrint.HughesPJClass hiding ( (<>) ) import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import URI.ByteString import URI.ByteString
@ -291,6 +292,24 @@ instance Pretty HadrianNotFound where
pPrint HadrianNotFound = pPrint HadrianNotFound =
text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?" text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
data GHCupShadowed = GHCupShadowed
FilePath -- shadow binary
FilePath -- upgraded binary
Version -- upgraded version
deriving Show
instance Pretty GHCupShadowed where
pPrint (GHCupShadowed sh up _) =
text ("ghcup is shadowed by "
<> sh
<> ". The upgrade will not be in effect, unless you remove "
<> sh
<> " or make sure "
<> takeDirectory up
<> " comes before "
<> takeDirectory sh
<> " in PATH."
)
------------------------- -------------------------
--[ High-level errors ]-- --[ High-level errors ]--