parent
ede6299681
commit
6c95218daf
@ -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
|
||||
|
||||
@ -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,42 +222,36 @@ 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"
|
||||
((info
|
||||
(Set <$> setParser <**> helper)
|
||||
( progDesc "Set currently active GHC/cabal version"
|
||||
<> footerDoc (Just $ text setFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"rm"
|
||||
( Rm
|
||||
<$> (info (rmOpts <**> helper) (progDesc "Remove a GHC version"))
|
||||
((info
|
||||
(Rm <$> rmParser <**> helper)
|
||||
( progDesc "Remove a GHC/cabal version"
|
||||
<> footerDoc (Just $ text rmFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
<> command
|
||||
"install-cabal"
|
||||
((info
|
||||
((InstallCabal <$> installOpts) <**> helper)
|
||||
( progDesc "Install or update cabal"
|
||||
<> footerDoc (Just $ text installCabalFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"list"
|
||||
( List
|
||||
<$> (info (listOpts <**> helper)
|
||||
((info (List <$> listOpts <**> helper)
|
||||
(progDesc "Show available GHCs and other tools")
|
||||
)
|
||||
)
|
||||
@ -284,7 +287,8 @@ com =
|
||||
)
|
||||
<> command
|
||||
"changelog"
|
||||
((info (fmap ChangeLog changelogP <**> helper)
|
||||
((info
|
||||
(fmap ChangeLog changelogP <**> helper)
|
||||
( progDesc "Find/show changelog"
|
||||
<> footerDoc (Just $ text changeLogFooter)
|
||||
)
|
||||
@ -293,24 +297,85 @@ com =
|
||||
<> 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>".|]
|
||||
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,8 +1002,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
exitWith (ExitFailure 2)
|
||||
runLogger $ checkForUpdates dls
|
||||
|
||||
res <- case optCommand of
|
||||
Install (InstallOptions {..}) ->
|
||||
|
||||
-----------------------
|
||||
-- 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
|
||||
@ -886,7 +1039,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
$(logError) [i|#{e}|]
|
||||
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
|
||||
pure $ ExitFailure 3
|
||||
InstallCabal (InstallOptions {..}) ->
|
||||
|
||||
|
||||
let installCabal InstallOptions{..} =
|
||||
(runInstTool $ do
|
||||
v <- liftE $ fromVersion dls instVer Cabal
|
||||
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
|
||||
@ -912,9 +1067,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
|
||||
pure $ ExitFailure 4
|
||||
|
||||
SetGHC (SetGHCOptions {..}) ->
|
||||
let setGHC' SetOptions{..} =
|
||||
(runSetGHC $ do
|
||||
v <- liftE $ fromVersion dls ghcVer GHC
|
||||
v <- liftE $ fromVersion dls sToolVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
@ -927,6 +1082,55 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
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 (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
|
||||
|
||||
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
|
||||
l <- listVersions dls lTool lCriteria
|
||||
@ -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)
|
||||
|
||||
153
lib/GHCup.hs
153
lib/GHCup.hs
@ -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,12 +746,12 @@ Stage1Only = YES|]
|
||||
|
||||
|
||||
|
||||
|
||||
compileCabal :: ( MonadReader Settings m
|
||||
, MonadResource m
|
||||
, MonadMask m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version -- ^ version to install
|
||||
@ -684,13 +759,16 @@ compileCabal :: ( MonadReader Settings m
|
||||
-> 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|])
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
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 r
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user