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

Fix disappearing HLS symlinks wrt #91

Browse Source 
When installing a new GHC version, the corresponding
HLS symlink of that version may be accidentially removed.

Ooops.
This commit is contained in:
Julian Ospald 2020-11-20 19:31:46 +01:00
parent fbb03dee7e
commit 1d3e88bdfe
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
3 changed files with 47 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CHANGELOG.md
View File

@ -2,6 +2,7 @@
## 0.1.12 -- ????-??-?? ## 0.1.12 -- ????-??-??
* Fix disappearing HLS symlinks wrt #91
* improve TUI: * improve TUI:
- separators between tools sections - separators between tools sections
- reverse list order so latest is on top - reverse list order so latest is on top

15
lib/GHCup.hs
View File

@ -535,8 +535,8 @@ setGHC ver sghc = do
-- with old ghcup) -- with old ghcup)
case sghc of case sghc of
SetGHCOnly -> liftE $ rmPlain (_tvTarget ver) SetGHCOnly -> liftE $ rmPlain (_tvTarget ver)
SetGHC_XY -> lift $ rmMajorSymlinks ver SetGHC_XY -> liftE $ rmMajorSymlinks ver
SetGHC_XYZ -> lift $ rmMinorSymlinks ver SetGHC_XYZ -> liftE $ rmMinorSymlinks ver
-- for ghc tools (ghc, ghci, haddock, ...) -- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver verfiles <- ghcToolFiles ver
@ -937,16 +937,17 @@ rmGHCVer ver = do
lift $ $(logInfo) [i|Removing ghc symlinks|] lift $ $(logInfo) [i|Removing ghc symlinks|]
liftE $ rmPlain (_tvTarget ver) liftE $ rmPlain (_tvTarget ver)
lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|]
liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|] lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
lift $ rmMinorSymlinks ver liftE $ rmMinorSymlinks ver
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|] lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-- first remove -- first remove
handle (\(_ :: ParseError) -> pure ()) $ lift $ rmMajorSymlinks ver handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version) -- then fix them (e.g. with an earlier version)
lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|]
liftIO $ deleteDirRecursive dir
v' <- v' <-
handle handle
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing) (\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)

69
lib/GHCup/Utils.hs
View File

@ -112,33 +112,40 @@ ghcLinkDestination tool ver = do
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
rmMinorSymlinks :: (MonadReader AppState m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m () rmMinorSymlinks :: ( MonadReader AppState m
rmMinorSymlinks GHCTargetVersion {..} = do , MonadIO m
AppState { dirs = Dirs {..} } <- ask , MonadLogger m
, MonadThrow m
files <- liftIO $ findFiles' , MonadFail m
binDir , MonadReader AppState m
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget )
*> parseUntil1 (MP.chunk $ prettyVer _tvVersion) => GHCTargetVersion
*> (MP.chunk $ prettyVer _tvVersion) -> Excepts '[NotInstalled] m ()
*> MP.eof rmMinorSymlinks tv@(GHCTargetVersion {..}) = do
) AppState { dirs = Dirs {..} } <- lift ask
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
let fullF = (binDir </> f) f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion)
$(logDebug) [i|rm -f #{toFilePath fullF}|] let fullF = (binDir </> f_xyz)
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- | Removes the set ghc version for the given target, if any. -- | Removes the set ghc version for the given target, if any.
rmPlain :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m) rmPlain :: ( MonadReader AppState m
=> Maybe Text -- ^ target , MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
)
=> Maybe Text -- ^ target
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmPlain target = do rmPlain target = do
AppState { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
mtv <- lift $ ghcSet target mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
let fullF = (binDir </> f) let fullF = (binDir </> f)
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|] lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
@ -150,25 +157,25 @@ rmPlain target = do
-- | Remove the major GHC symlink, e.g. ghc-8.6. -- | Remove the major GHC symlink, e.g. ghc-8.6.
rmMajorSymlinks :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m) rmMajorSymlinks :: ( MonadReader AppState m
, MonadIO m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> GHCTargetVersion => GHCTargetVersion
-> m () -> Excepts '[NotInstalled] m ()
rmMajorSymlinks GHCTargetVersion {..} = do rmMajorSymlinks tv@(GHCTargetVersion {..}) = do
AppState { dirs = Dirs {..} } <- ask AppState { dirs = Dirs {..} } <- lift ask
(mj, mi) <- getMajorMinorV _tvVersion (mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi let v' = intToText mj <> "." <> intToText mi
files <- liftIO $ findFiles' files <- liftE $ ghcToolFiles tv
binDir
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk v')
*> MP.chunk v'
*> MP.eof
)
forM_ files $ \f -> do forM_ files $ \f -> do
let fullF = (binDir </> f) f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> E.encodeUtf8 v')
$(logDebug) [i|rm -f #{toFilePath fullF}|] let fullF = (binDir </> f_xyz)
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF liftIO $ hideError doesNotExistErrorType $ deleteFile fullF