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

Re-enable upgrade functionality for all configurations

Browse Source 
Adds a --fail-if-shadowed switch.
This commit is contained in:
Julian Ospald 2022-05-02 19:54:37 +02:00
parent 3964d06f5d
commit b036c9861f
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
, FileAlreadyExistsError
, ProcessError
, GHCupShadowed
]
run (do
@ -452,7 +453,7 @@ install' _ (_, ListResult {..}) = do
liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce)
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce)
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
HLS -> do
let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce)

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

@ -96,7 +96,7 @@ data Command
| Config ConfigCommand
| Whereis WhereisOptions WhereisCommand
#ifndef DISABLE_UPGRADE
| Upgrade UpgradeOpts Bool
| Upgrade UpgradeOpts Bool Bool
#endif
| ToolRequirements ToolReqOpts
| ChangeLog ChangeLogOptions
@ -222,18 +222,18 @@ com =
(info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
#ifndef DISABLE_UPGRADE
<> command
"upgrade"
(info
( (Upgrade <$> upgradeOptsP <*> switch
(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
)
(progDesc "Upgrade ghcup")
)
#endif
<> command
"compile"
( Compile

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

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

46
app/ghcup/Main.hs
View File

@ -141,9 +141,7 @@ main = do
)
let listCommands = infoOption
("install set rm install-cabal list"
#ifndef DISABLE_UPGRADE
<> " upgrade"
#endif
<> " compile debug-info tool-requirements changelog"
)
( long "list-commands"
@ -245,14 +243,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
alreadyInstalling' <- alreadyInstalling optCommand newTool
when (not alreadyInstalling') $
case t of
#ifdef DISABLE_UPGRADE
GHCup -> pure ()
#else
GHCup -> runLogger $
logWarn ("New GHCup version available: "
<> prettyVer l
<> ". To upgrade, run 'ghcup upgrade'")
#endif
_ -> runLogger $
logWarn ("New "
<> T.pack (prettyShow t)
@ -296,26 +290,24 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
s' <- appState
liftIO $ brickMain s' >> pure ExitSuccess
#endif
Install installCommand -> install installCommand settings appState runLogger
InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger
Set setCommand -> set setCommand runAppState runLeanAppState runLogger
UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger
List lo -> list lo no_color runAppState
Rm rmCommand -> rm rmCommand runAppState runLogger
DInfo -> dinfo runAppState runLogger
Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger
Config configCommand -> config configCommand settings keybindings runLogger
Install installCommand -> install installCommand settings appState runLogger
InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger
Set setCommand -> set setCommand runAppState runLeanAppState runLogger
UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger
List lo -> list lo no_color runAppState
Rm rmCommand -> rm rmCommand runAppState runLogger
DInfo -> dinfo runAppState runLogger
Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger
Config configCommand -> config configCommand settings keybindings runLogger
Whereis whereisOptions
whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
#ifndef DISABLE_UPGRADE
Upgrade uOpts force' -> upgrade uOpts force' dirs runAppState runLogger
#endif
ToolRequirements topts -> toolRequirements topts runAppState runLogger
ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger
Nuke -> nuke appState runLogger
Prefetch pfCom -> prefetch pfCom runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand appState leanAppstate runLogger
whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger
ToolRequirements topts -> toolRequirements topts runAppState runLogger
ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger
Nuke -> nuke appState runLogger
Prefetch pfCom -> prefetch pfCom runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand appState leanAppstate runLogger
case res of
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
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
#ifndef DISABLE_UPGRADE
alreadyInstalling (Upgrade _ _) (GHCup, _) = pure True
#endif
alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True
alreadyInstalling _ _ = pure False
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
(`/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
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
manual: True
flag disable-upgrade
description:
Disable upgrade functionality. This is mainly to support brew packagers.
default: False
manual: True
library
exposed-modules:
GHCup
@ -204,6 +197,7 @@ executable ghcup
GHCup.OptParse.Set
GHCup.OptParse.ToolRequirements
GHCup.OptParse.UnSet
GHCup.OptParse.Upgrade
GHCup.OptParse.Whereis
hs-source-dirs: app/ghcup
@ -277,11 +271,6 @@ executable ghcup
if flag(no-exe)
buildable: False
if flag(disable-upgrade)
cpp-options: -DDISABLE_UPGRADE
else
other-modules: GHCup.OptParse.Upgrade
test-suite ghcup-test
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
-> Bool -- ^ whether to force update regardless
-- of currently installed version
-> Bool -- ^ whether to throw an error if ghcup is shadowed
-> Excepts
'[ CopyError
, DigestError
@ -2595,10 +2596,11 @@ upgradeGHCup :: ( MonadMask m
, DownloadFailed
, NoDownload
, NoUpdate
, GHCupShadowed
]
m
Version
upgradeGHCup mtarget force' = do
upgradeGHCup mtarget force' fatal = do
Dirs {..} <- lift getDirs
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."
liftIO (isShadowed destFile) >>= \case
Nothing -> pure ()
Just pa -> lift $ logWarn $ "ghcup is shadowed by "
<> T.pack pa
<> ". The upgrade will not be in effect, unless you remove "
<> T.pack pa
<> " or make sure "
<> T.pack destDir
<> " comes before "
<> T.pack (takeFileName pa)
<> " in PATH."
Just pa
| fatal -> throwE (GHCupShadowed pa destFile latestVer)
| otherwise ->
lift $ logWarn $ "ghcup is shadowed by "
<> T.pack pa
<> ". The upgrade will not be in effect, unless you remove "
<> T.pack pa
<> " or make sure "
<> T.pack destDir
<> " comes before "
<> T.pack (takeDirectory pa)
<> " in PATH."
pure latestVer

19
lib/GHCup/Errors.hs
View File

@ -27,6 +27,7 @@ import Data.CaseInsensitive ( CI )
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant
import System.FilePath
import Text.PrettyPrint hiding ( (<>) )
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import URI.ByteString
@ -291,6 +292,24 @@ instance Pretty HadrianNotFound where
pPrint HadrianNotFound =
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 ]--