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

Remove legacy handling of cabal binary

Browse Source
This commit is contained in:
Julian Ospald 2021-06-12 22:26:50 +02:00
parent a396b6044d
commit 4dcc63606e
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
2 changed files with 17 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lib/GHCup.hs
View File

@ -878,7 +878,7 @@ listVersions :: ( MonadCatch m
listVersions lt' criteria = do listVersions lt' criteria = do
-- some annoying work to avoid too much repeated IO -- some annoying work to avoid too much repeated IO
cSet <- cabalSet cSet <- cabalSet
cabals <- getInstalledCabals' cSet cabals <- getInstalledCabals
hlsSet' <- hlsSet hlsSet' <- hlsSet
hlses <- getInstalledHLSs hlses <- getInstalledHLSs
sSet <- stackSet sSet <- stackSet

52
lib/GHCup/Utils.hs
View File

@ -87,7 +87,6 @@ import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.BZip as BZip import qualified Codec.Compression.BZip as BZip
import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma import qualified Codec.Compression.Lzma as Lzma
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Text as T import qualified Data.Text as T
@ -253,14 +252,6 @@ getInstalledGHCs = do
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m) getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either FilePath Version] => m [Either FilePath Version]
getInstalledCabals = do getInstalledCabals = do
cs <- cabalSet -- for legacy cabal
getInstalledCabals' cs
getInstalledCabals' :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> Maybe Version
-> m [Either FilePath Version]
getInstalledCabals' cs = do
AppState {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
@ -269,7 +260,7 @@ getInstalledCabals' cs = do
Just (Right r) -> pure $ Right r Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f Nothing -> pure $ Left f
pure $ maybe vs (\x -> nub $ Right x:vs) cs pure $ nub vs
-- | Whether the given cabal version is installed. -- | Whether the given cabal version is installed.
@ -284,32 +275,21 @@ cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, Mon
cabalSet = do cabalSet = do
AppState {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> "cabal" <> exeExt let cabalbin = binDir </> "cabal" <> exeExt
b <- handleIO (\_ -> pure False) $ liftIO $ pathIsLink cabalbin
if handleIO' NoSuchThing (\_ -> pure Nothing) $ do
| b -> do broken <- liftIO $ isBrokenSymlink cabalbin
handleIO' NoSuchThing (\_ -> pure Nothing) $ do if broken
broken <- liftIO $ isBrokenSymlink cabalbin then pure Nothing
if broken else do
then pure Nothing link <- liftIO
else do $ handleIO' InvalidArgument
link <- liftIO $ getLinkTarget cabalbin (\e -> pure $ Left (toException e))
case linkVersion link of $ fmap Right $ getLinkTarget cabalbin
Right v -> pure $ Just v case linkVersion =<< link of
Left err -> do Right v -> pure $ Just v
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|] Left err -> do
pure Nothing $(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
| otherwise -> do -- legacy behavior pure Nothing
mc <- handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (BL.null (_stdOut c)), _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd isNewLine . BL.toStrict . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
where where
-- We try to be extra permissive with link destination parsing, -- We try to be extra permissive with link destination parsing,
-- because of: -- because of: