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

Support multiple installed versions of cabal 

Fixes #23
This commit is contained in:
Julian Ospald 2020-05-11 00:18:53 +02:00
parent ede6299681
commit 6c95218daf
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
4 changed files with 501 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
README.md
View File

@ -47,16 +47,16 @@ Common use cases are:
ghcup list
# install the recommended GHC version
ghcup install
ghcup install ghc
# install a specific GHC version
ghcup install 8.2.2
ghcup install ghc 8.2.2
# set the currently "active" GHC version
ghcup set 8.4.4
ghcup set ghc 8.4.4
# install cabal-install
ghcup install-cabal
ghcup install cabal
# update ghcup itself
ghcup upgrade

472
app/ghcup/Main.hs
View File

@ -82,11 +82,11 @@ data Options = Options
}
data Command
= Install InstallOptions
| InstallCabal InstallOptions
| SetGHC SetGHCOptions
= Install (Either InstallCommand InstallOptions)
| InstallCabalLegacy InstallOptions
| Set (Either SetCommand SetOptions)
| List ListOptions
| Rm RmOptions
| Rm (Either RmCommand RmOptions)
| DInfo
| Compile CompileCommand
| Upgrade UpgradeOpts Bool
@ -101,13 +101,19 @@ prettyToolVer (ToolVersion v') = T.unpack $ prettyTVer v'
prettyToolVer (ToolTag t) = show t
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
}
data SetGHCOptions = SetGHCOptions
{ ghcVer :: Maybe ToolVersion
data SetCommand = SetGHC SetOptions
| SetCabal SetOptions
data SetOptions = SetOptions
{ sToolVer :: Maybe ToolVersion
}
data ListOptions = ListOptions
@ -116,6 +122,9 @@ data ListOptions = ListOptions
, lRawFormat :: Bool
}
data RmCommand = RmGHC RmOptions
| RmCabal Version
data RmOptions = RmOptions
{ ghcVer :: GHCTargetVersion
}
@ -213,44 +222,38 @@ com =
subparser
( command
"install"
((info
((Install <$> installOpts) <**> helper)
( progDesc "Install or update GHC"
<> footerDoc (Just $ text installFooter)
)
)
( Install
<$> (info
(installParser <**> helper)
( progDesc "Install or update GHC/cabal"
<> footerDoc (Just $ text installToolFooter)
)
)
)
<> command
"set"
( SetGHC
<$> (info
(setGHCOpts <**> helper)
( progDesc "Set currently active GHC version"
<> footerDoc (Just $ text setFooter)
)
)
)
<> command
"rm"
( Rm
<$> (info (rmOpts <**> helper) (progDesc "Remove a GHC version"))
)
<> command
"install-cabal"
((info
((InstallCabal <$> installOpts) <**> helper)
( progDesc "Install or update cabal"
<> footerDoc (Just $ text installCabalFooter)
(Set <$> setParser <**> helper)
( progDesc "Set currently active GHC/cabal version"
<> footerDoc (Just $ text setFooter)
)
)
)
<> command
"rm"
((info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal version"
<> footerDoc (Just $ text rmFooter)
)
)
)
<> command
"list"
( List
<$> (info (listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
((info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
)
<> command
"upgrade"
@ -284,33 +287,95 @@ com =
)
<> command
"changelog"
((info (fmap ChangeLog changelogP <**> helper)
(progDesc "Find/show changelog"
<> footerDoc (Just $ text changeLogFooter)
)
((info
(fmap ChangeLog changelogP <**> helper)
( progDesc "Find/show changelog"
<> footerDoc (Just $ text changeLogFooter)
)
)
)
<> commandGroup "Other commands:"
<> hidden
)
<|> subparser
( command
"install-cabal"
((info
((InstallCabalLegacy <$> installOpts) <**> helper)
( progDesc "Install or update cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
)
<> internal
)
where
installFooter = [i|Discussion:
Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
installToolFooter :: String
installToolFooter = [i|Discussion:
Installs GHC or cabal. When no command is given, installs GHC
with the specified version/tag.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
setFooter :: String
setFooter = [i|Discussion:
Sets the the current GHC version by creating non-versioned
symlinks for all ghc binaries of the specified version in
"~/.ghcup/bin/<binary>".|]
installCabalFooter = [i|Discussion:
Sets the currently active GHC or cabal version. When no command is given,
defaults to setting GHC with the specified version/tag (if no tag
is given, sets GHC to 'recommended' version).
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
rmFooter :: String
rmFooter = [i|Discussion:
Remove the given GHC or cabal version. When no command is given,
defaults to removing GHC with the specified version.
It is recommended to always specify a subcommand ('ghc' or 'cabal').|]
changeLogFooter :: String
changeLogFooter = [i|Discussion:
By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|]
installCabalFooter :: String
installCabalFooter = [i|Discussion:
Installs the specified cabal-install version (or a recommended default one)
into "~/.ghcup/bin", so it can be overwritten by later
"cabal install cabal-install", which installs into "~/.cabal/bin" by
default. Make sure to set up your PATH appropriately, so the cabal
installation takes precedence.|]
changeLogFooter = [i|Discussion:
By default returns the URI of the ChangeLog of the latest GHC release.
Pass '-o' to automatically open via xdg-open.|]
installParser :: Parser (Either InstallCommand InstallOptions)
installParser =
(Left <$> subparser
( command
"ghc"
( InstallGHC
<$> (info
(installOpts <**> helper)
( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter)
)
)
)
<> command
"cabal"
( InstallCabal
<$> (info
(installOpts <**> helper)
( progDesc "Install Cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
)
)
)
<|> (Right <$> installOpts)
where
installGHCFooter :: String
installGHCFooter = [i|Discussion:
Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
installOpts :: Parser InstallOptions
@ -330,8 +395,46 @@ installOpts =
<*> optional toolVersionArgument
setGHCOpts :: Parser SetGHCOptions
setGHCOpts = SetGHCOptions <$> optional toolVersionArgument
setParser :: Parser (Either SetCommand SetOptions)
setParser =
(Left <$> subparser
( command
"ghc"
( SetGHC
<$> (info
(setOpts <**> helper)
( progDesc "Set GHC version"
<> footerDoc (Just $ text setGHCFooter)
)
)
)
<> command
"cabal"
( SetCabal
<$> (info
(setOpts <**> helper)
( progDesc "Set Cabal version"
<> footerDoc (Just $ text setCabalFooter)
)
)
)
)
)
<|> (Right <$> setOpts)
where
setGHCFooter :: String
setGHCFooter = [i|Discussion:
Sets the the current GHC version by creating non-versioned
symlinks for all ghc binaries of the specified version in
"~/.ghcup/bin/<binary>".|]
setCabalFooter :: String
setCabalFooter = [i|Discussion:
Sets the the current Cabal version.|]
setOpts :: Parser SetOptions
setOpts = SetOptions <$> optional toolVersionArgument
listOpts :: Parser ListOptions
listOpts =
@ -357,6 +460,26 @@ listOpts =
(short 'r' <> long "raw-format" <> help "More machine-parsable format"
)
rmParser :: Parser (Either RmCommand RmOptions)
rmParser =
(Left <$> subparser
( command
"ghc"
(RmGHC <$> (info (rmOpts <**> helper) (progDesc "Remove GHC version")))
<> command
"cabal"
( RmCabal
<$> (info (versionParser' <**> helper)
(progDesc "Remove Cabal version")
)
)
)
)
<|> (Right <$> rmOpts)
rmOpts :: Parser RmOptions
rmOpts = RmOptions <$> versionArgument
@ -534,6 +657,12 @@ versionParser = option
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
)
versionParser' :: Parser Version
versionParser' = argument
(eitherReader (bimap show id . version . T.pack))
(metavar "VERSION")
tagEither :: String -> Either String Tag
tagEither s' = case fmap toLower s' of
"recommended" -> Right Recommended
@ -744,7 +873,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, rawOutter = appendFile logfile
}
-- wrapper to run effects with settings
-------------------------
-- Effect interpreters --
-------------------------
let runInstTool =
runLogger
. flip runReaderT settings
@ -776,6 +909,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound
]
let
runSetCabal =
runLogger
. runE
@'[ NotInstalled
, TagNotFound
]
let runListGHC = runE @'[] . runLogger
let runRmGHC =
@ -811,13 +952,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. flip runReaderT settings
. runResourceT
. runE
@'[ BuildFailed
@'[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
]
@ -838,6 +982,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, DownloadFailed
]
---------------------------
-- Getting download info --
---------------------------
(GHCupInfo treq dls) <-
( runLogger
. flip runReaderT settings
@ -853,79 +1002,134 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
exitWith (ExitFailure 2)
runLogger $ checkForUpdates dls
-----------------------
-- Command functions --
-----------------------
let installGHC InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("GHC installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available GHC version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended GHC version|]
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 3
let installCabal InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("Cabal installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available Cabal version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended Cabal version|]
pure $ ExitFailure 4
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
(runSetGHC $ do
v <- liftE $ fromVersion dls sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight (GHCTargetVersion{..}) -> do
runLogger
$ $(logInfo)
[i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|]
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 5
let setCabal' SetOptions{..} =
(runSetCabal $ do
v <- liftE $ fromVersion dls sToolVer Cabal
liftE $ setCabal (_tvVersion v)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
(runRmGHC $ do
liftE $ rmGHCVer ghcVer
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 7
let rmCabal' tv =
(runSetCabal $ do
liftE $ rmCabalVer tv
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 15
res <- case optCommand of
Install (InstallOptions {..}) ->
(runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("GHC installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3
VLeft (V NoDownload) -> do
Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
installGHC iopts
Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts
InstallCabalLegacy iopts -> do
runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
installCabal iopts
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available GHC version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended GHC version|]
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 3
InstallCabal (InstallOptions {..}) ->
(runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("Cabal installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available Cabal version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended Cabal version|]
pure $ ExitFailure 4
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
pure $ ExitFailure 4
SetGHC (SetGHCOptions {..}) ->
(runSetGHC $ do
v <- liftE $ fromVersion dls ghcVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight (GHCTargetVersion{..}) -> do
runLogger
$ $(logInfo)
[i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|]
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 5
Set (Right sopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.|])
setGHC' sopts
Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' sopts
List (ListOptions {..}) ->
(runListGHC $ do
@ -940,15 +1144,11 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 6
Rm (RmOptions {..}) ->
(runRmGHC $ do
liftE $ rmGHCVer ghcVer
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 7
Rm (Right rmopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
rmGHC' rmopts
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
DInfo ->
do
@ -1182,14 +1382,14 @@ checkForUpdates dls = do
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
$ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install #{prettyVer l}'|]
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \l -> do
mcabal_ver <- latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install-cabal #{prettyVer l}'|]
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
where
latestInstalled tool = (fmap lVer . lastMay)

155
lib/GHCup.hs
View File

@ -38,6 +38,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.ByteString ( ByteString )
import Data.Either
import Data.List
import Data.Maybe
import Data.String.Interpolate
@ -53,6 +54,7 @@ import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe hiding ( at )
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import System.Posix.FilePath ( getSearchPath )
@ -148,24 +150,39 @@ installCabalBin :: ( MonadMask m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ CopyError
'[ AlreadyInstalled
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, UnknownArchive
]
m
()
installCabalBin bDls ver mpfReq = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
bindir <- liftIO ghcupBinDir
whenM
(liftIO $ cabalInstalled ver >>= \a ->
handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (bindir </> [rel|cabal|]))
)
$ (throwE $ AlreadyInstalled Cabal ver)
Settings {..} <- lift ask
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
@ -178,13 +195,16 @@ installCabalBin bDls ver mpfReq = do
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths
bindir <- liftIO ghcupBinDir
-- the subdir of the archive where we do the work
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
liftE $ installCabal' workdir bindir
-- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
pure ()
where
@ -197,16 +217,17 @@ installCabalBin bDls ver mpfReq = do
lift $ $(logInfo) "Installing cabal"
let cabalFile = [rel|cabal|]
liftIO $ createDirIfMissing newDirPerms inst
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
(inst </> cabalFile)
(inst </> destFileName)
Overwrite
---------------
--[ Set GHC ]--
---------------
---------------------
--[ Set GHC/cabal ]--
---------------------
@ -283,6 +304,40 @@ setGHC ver sghc = do
-- | Set the ~/.ghcup/bin/cabal symlink.
setCabal :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
setCabal ver = do
let verBS = verToBS ver
targetFile <- parseRel ("cabal-" <> verBS)
-- symlink destination
bindir <- liftIO $ ghcupBinDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
whenM (liftIO $ fmap not $ doesFileExist (bindir </> targetFile))
$ throwE
$ NotInstalled Cabal (prettyVer ver)
let cabalbin = bindir </> [rel|cabal|]
-- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile
cabalbin
-- create symlink
let destL = toFilePath targetFile
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath cabalbin}|]
liftIO $ createSymlink cabalbin destL
pure ()
------------------
--[ List tools ]--
@ -386,8 +441,8 @@ listVersions av lt criteria = case lt of
fromSrc <- ghcSrcInstalled tver
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do
lSet <- fmap (== v) $ cabalSet
let lInstalled = lSet
lSet <- fmap (maybe False (== v)) $ cabalSet
lInstalled <- cabalInstalled v
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
@ -417,9 +472,9 @@ listVersions av lt criteria = case lt of
--------------
--[ GHC rm ]--
--------------
--------------------
--[ GHC/cabal rm ]--
--------------------
-- | This function may throw and crash in various ways.
@ -461,6 +516,26 @@ rmGHCVer ver = do
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
-- | This function may throw and crash in various ways.
rmCabalVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
=> Version
-> Excepts '[NotInstalled] m ()
rmCabalVer ver = do
whenM (fmap not $ liftIO $ cabalInstalled ver) $ throwE (NotInstalled GHC (prettyVer ver))
cSet <- liftIO cabalSet
bindir <- liftIO ghcupBinDir
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> cabalFile)
when (maybe False (== ver) cSet) $ do
cVers <- liftIO $ fmap rights $ getInstalledCabals
case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
(bindir </> [rel|cabal|])
------------------
@ -671,26 +746,29 @@ Stage1Only = YES|]
compileCabal :: ( MonadReader Settings m
, MonadResource m
, MonadMask m
, MonadLogger m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version -- ^ version to install
-> Version -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int
-> Maybe (Path Abs)
-> Excepts
'[ BuildFailed
'[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
]
@ -699,6 +777,17 @@ compileCabal :: ( MonadReader Settings m
compileCabal dls tver bghc jobs patchdir = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
bindir <- liftIO ghcupBinDir
whenM
(liftIO $ cabalInstalled tver >>= \a ->
handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (bindir </> [rel|cabal|]))
)
$ (throwE $ AlreadyInstalled Cabal tver)
-- download source tarball
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
@ -711,21 +800,25 @@ compileCabal dls tver bghc jobs patchdir = do
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir)
liftE $ runBuildAction
tmpUnpack
Nothing
(compile workdir)
destFileName <- lift $ parseRel ("cabal-" <> verToBS tver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
cbin
(bindir </> destFileName)
Overwrite
-- only clean up dir if the build succeeded
liftIO $ deleteDirRecursive tmpUnpack
-- create symlink if this is the latest version
cVers <- liftIO $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver
pure ()
where
compile :: (MonadThrow m, MonadLogger m, MonadIO m)
compile :: (MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
=> Path Abs
-> Excepts '[ProcessError , PatchFailed] m ()
-> Excepts '[ProcessError , PatchFailed] m (Path Abs)
compile workdir = do
lift $ $(logInfo) [i|Building (this may take a while)...|]
@ -741,14 +834,19 @@ compileCabal dls tver bghc jobs patchdir = do
pure
[ ("GHC" , toFilePath path)
, ("GHC_PKG", dn <> "/" <> "ghc-pkg" <> ver)
, ("HADDOCK", dn <> "/" <> "haddock" <> ver)
]
Left bver -> do
let v' = verToBS bver
pure [("GHC", "ghc-" <> v'), ("GHC_PKG", "ghc-pkg-" <> v')]
pure
[ ("GHC" , "ghc-" <> v')
, ("GHC_PKG", "ghc-pkg-" <> v')
, ("HADDOCK", "haddock-" <> v')
]
cabal_bin <- liftIO $ ghcupBinDir
newEnv <- lift
$ addToCurrentEnv (("PREFIX", toFilePath cabal_bin) : ghcEnv)
tmp <- lift withGHCupTmpDir
liftIO $ createDirRecursive newDirPerms (tmp </> [rel|bin|])
newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
lift $ $(logDebug) [i|Environment: #{newEnv}|]
lEM $ liftIO $ execLogged "./bootstrap.sh"
@ -757,6 +855,7 @@ compileCabal dls tver bghc jobs patchdir = do
[rel|cabal-bootstrap|]
(Just workdir)
(Just newEnv)
pure $ (tmp </> [rel|bin/cabal|])

45
lib/GHCup/Utils.hs
View File

@ -210,19 +210,41 @@ getInstalledGHCs = do
Left _ -> pure $ Left f
getInstalledCabals :: IO [Either (Path Rel) Version]
getInstalledCabals = do
bindir <- liftIO $ ghcupBinDir
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
bindir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
cs <- cabalSet -- for legacy cabal
pure $ maybe vs (\x -> Right x:vs) cs
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
reportedVer <- cabalSet
pure (reportedVer == ver)
vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers
cabalSet :: (MonadIO m, MonadThrow m) => m Version
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
cabalSet = do
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
mc <- liftIO $ executeOut cabalbin ["--numeric-version"] Nothing
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure r
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (B.null (_stdOut c))
, _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
@ -463,11 +485,11 @@ getChangeLog dls tool (Right tag) =
runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
=> Path Abs -- ^ build directory
-> Maybe (Path Abs) -- ^ install location (e.g. for GHC)
-> Excepts e m ()
-> Excepts '[BuildFailed] m ()
-> Excepts e m a
-> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do
Settings {..} <- lift ask
flip
v <- flip
onException
(do
forM_ instdir $ \dir ->
@ -491,3 +513,4 @@ runBuildAction bdir instdir action = do
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
bdir
pure v