Fix cleaning up directories of compiled tools

'fromSrc' doesn't work well anyway.
This commit is contained in:
Julian Ospald 2023-07-18 09:28:25 +08:00
parent 09d72e7c97
commit 5170baf074
No known key found for this signature in database
GPG Key ID: CCC85C0E40C06A8C
6 changed files with 27 additions and 48 deletions

View File

@ -51,6 +51,14 @@ eghcup set ghc "${CROSS}-${GHC_TARGET_VERSION}"
[ "$($(eghcup whereis ghc "${CROSS}-${GHC_TARGET_VERSION}") --numeric-version)" = "${GHC_TARGET_VERSION}" ] [ "$($(eghcup whereis ghc "${CROSS}-${GHC_TARGET_VERSION}") --numeric-version)" = "${GHC_TARGET_VERSION}" ]
# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke'
mkdir no_nuke/
mkdir no_nuke/bar
echo 'foo' > no_nuke/file
echo 'bar' > no_nuke/bar/file
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/cache/no_nuke
ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/logs/no_nuke
# nuke # nuke
eghcup nuke eghcup nuke
[ ! -e "${GHCUP_DIR}" ] [ ! -e "${GHCUP_DIR}" ]

View File

@ -218,7 +218,6 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
printNotes ListResult {..} = printNotes ListResult {..} =
(if hlsPowered then [withAttr (attrName "hls-powered") $ str "hls-powered"] else mempty (if hlsPowered then [withAttr (attrName "hls-powered") $ str "hls-powered"] else mempty
) )
++ (if fromSrc then [withAttr (attrName "compiled") $ str "compiled"] else mempty)
++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty) ++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty)
++ (case lReleaseDay of ++ (case lReleaseDay of
Nothing -> mempty Nothing -> mempty

View File

@ -180,7 +180,6 @@ printListResult no_color raw lr = do
then [color Green "hls-powered"] then [color Green "hls-powered"]
else mempty else mempty
) )
++ (if fromSrc then [color Blue "compiled"] else mempty)
++ (if lStray then [color Yellow "stray"] else mempty) ++ (if lStray then [color Yellow "stray"] else mempty)
++ (case lReleaseDay of ++ (case lReleaseDay of
Nothing -> mempty Nothing -> mempty

View File

@ -947,14 +947,14 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
IsolateDir isoDir -> pure $ IsolateDirResolved isoDir IsolateDir isoDir -> pure $ IsolateDirResolved isoDir
GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer)
(mBindist, bmk) <- liftE $ runBuildAction mBindist <- liftE $ runBuildAction
tmpUnpack tmpUnpack
(do (do
-- prefer 'tver', because the real version carries out compatibility checks -- prefer 'tver', because the real version carries out compatibility checks
-- we don't want the user to do funny things with it -- we don't want the user to do funny things with it
let doHadrian = compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir let doHadrian = compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
doMake = compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir doMake = compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir
b <- case buildSystem of case buildSystem of
Just Hadrian -> do Just Hadrian -> do
lift $ logInfo "Requested to use Hadrian" lift $ logInfo "Requested to use Hadrian"
liftE doHadrian liftE doHadrian
@ -972,8 +972,6 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
else do else do
lift $ logInfo "Detected Make" lift $ logInfo "Detected Make"
doMake doMake
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir)
pure (b, bmk)
) )
case installDir of case installDir of
@ -993,8 +991,6 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
False -- not a force install, since we already overwrite when compiling. False -- not a force install, since we already overwrite when compiling.
[] []
liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk
case installDir of case installDir of
-- set and make symlinks for regular (non-isolated) installs -- set and make symlinks for regular (non-isolated) installs
GHCupInternal -> do GHCupInternal -> do

View File

@ -76,7 +76,6 @@ data ListResult = ListResult
, lTag :: [Tag] , lTag :: [Tag]
, lInstalled :: Bool , lInstalled :: Bool
, lSet :: Bool -- ^ currently active version , lSet :: Bool -- ^ currently active version
, fromSrc :: Bool -- ^ compiled from source
, lStray :: Bool -- ^ not in download info , lStray :: Bool -- ^ not in download info
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
, hlsPowered :: Bool , hlsPowered :: Bool
@ -169,7 +168,6 @@ listVersions lt' criteria hideOld showNightly days = do
Just _ -> pure Nothing Just _ -> pure Nothing
Nothing -> do Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
@ -213,7 +211,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing , lReleaseDay = Nothing
, .. , ..
@ -248,7 +245,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing , lReleaseDay = Nothing
, .. , ..
@ -284,7 +280,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
, lReleaseDay = Nothing , lReleaseDay = Nothing
, .. , ..
@ -306,7 +301,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lTag = maybe (if isOld then [Old] else []) _viTags listVer , lTag = maybe (if isOld then [Old] else []) _viTags listVer
, lCross = Nothing , lCross = Nothing
, lTool = GHCup , lTool = GHCup
, fromSrc = False
, lStray = isNothing listVer , lStray = isNothing listVer
, lSet = True , lSet = True
, lInstalled = True , lInstalled = True
@ -340,7 +334,6 @@ listVersions lt' criteria hideOld showNightly days = do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver
lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver) lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver)
lInstalled <- ghcInstalled tver lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions) hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions)
pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. } pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. }
Cabal -> do Cabal -> do
@ -351,7 +344,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lCross = Nothing , lCross = Nothing
, lTag = _viTags , lTag = _viTags
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay , lReleaseDay = _viReleaseDay
@ -364,7 +356,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lTag = _viTags , lTag = _viTags
, lCross = Nothing , lCross = Nothing
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, lNoBindist = False , lNoBindist = False
, hlsPowered = False , hlsPowered = False
@ -379,7 +370,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lCross = Nothing , lCross = Nothing
, lTag = _viTags , lTag = _viTags
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay , lReleaseDay = _viReleaseDay
@ -393,7 +383,6 @@ listVersions lt' criteria hideOld showNightly days = do
, lCross = Nothing , lCross = Nothing
, lTag = _viTags , lTag = _viTags
, lTool = t , lTool = t
, fromSrc = False
, lStray = False , lStray = False
, hlsPowered = False , hlsPowered = False
, lReleaseDay = _viReleaseDay , lReleaseDay = _viReleaseDay

View File

@ -288,13 +288,6 @@ ghcInstalled ver = do
liftIO $ doesDirectoryExist (fromGHCupPath ghcdir) liftIO $ doesDirectoryExist (fromGHCupPath ghcdir)
-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (fromGHCupPath ghcdir </> ghcUpSrcBuiltFile)
-- | Whether the given GHC version is set as the current. -- | Whether the given GHC version is set as the current.
ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
=> Maybe Text -- ^ the target of the GHC version, if any => Maybe Text -- ^ the target of the GHC version, if any
@ -975,11 +968,6 @@ ghcToolFiles ver = do
isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
-- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: FilePath
ghcUpSrcBuiltFile = ".ghcup_src_built"
-- | Calls gmake if it exists in PATH, otherwise make. -- | Calls gmake if it exists in PATH, otherwise make.
make :: ( MonadThrow m make :: ( MonadThrow m