From 5170baf07434b8d2eba626c38adc809abd15725d Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 18 Jul 2023 09:28:25 +0800 Subject: [PATCH] Fix cleaning up directories of compiled tools 'fromSrc' doesn't work well anyway. --- .github/scripts/cross.sh | 8 ++++++ app/ghcup/BrickMain.hs | 1 - app/ghcup/GHCup/OptParse/List.hs | 1 - lib/GHCup/GHC.hs | 42 +++++++++++++++----------------- lib/GHCup/List.hs | 11 --------- lib/GHCup/Utils.hs | 12 --------- 6 files changed, 27 insertions(+), 48 deletions(-) diff --git a/.github/scripts/cross.sh b/.github/scripts/cross.sh index efb2eca..d29024c 100644 --- a/.github/scripts/cross.sh +++ b/.github/scripts/cross.sh @@ -51,6 +51,14 @@ eghcup set ghc "${CROSS}-${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 eghcup nuke [ ! -e "${GHCUP_DIR}" ] diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index e6f8921..49baa81 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -218,7 +218,6 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..} printNotes ListResult {..} = (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) ++ (case lReleaseDay of Nothing -> mempty diff --git a/app/ghcup/GHCup/OptParse/List.hs b/app/ghcup/GHCup/OptParse/List.hs index 56a6c0f..c93dc3a 100644 --- a/app/ghcup/GHCup/OptParse/List.hs +++ b/app/ghcup/GHCup/OptParse/List.hs @@ -180,7 +180,6 @@ printListResult no_color raw lr = do then [color Green "hls-powered"] else mempty ) - ++ (if fromSrc then [color Blue "compiled"] else mempty) ++ (if lStray then [color Yellow "stray"] else mempty) ++ (case lReleaseDay of Nothing -> mempty diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index 7b3fb70..42372b9 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -947,33 +947,31 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build IsolateDir isoDir -> pure $ IsolateDirResolved isoDir GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) - (mBindist, bmk) <- liftE $ runBuildAction + mBindist <- liftE $ runBuildAction tmpUnpack (do -- prefer 'tver', because the real version carries out compatibility checks -- we don't want the user to do funny things with it let doHadrian = compileHadrianBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir doMake = compileMakeBindist (fromMaybe installVer tver) (fromGHCupPath workdir) ghcdir - b <- case buildSystem of - Just Hadrian -> do - lift $ logInfo "Requested to use Hadrian" - liftE doHadrian - Just Make -> do - lift $ logInfo "Requested to use Make" - doMake - Nothing -> do - supportsHadrian <- liftE $ catchE @HadrianNotFound @'[HadrianNotFound] @'[] (\_ -> return False) - $ fmap (const True) - $ findHadrianFile (fromGHCupPath workdir) - if supportsHadrian - then do - lift $ logInfo "Detected Hadrian" - liftE doHadrian - else do - lift $ logInfo "Detected Make" - doMake - bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir) - pure (b, bmk) + case buildSystem of + Just Hadrian -> do + lift $ logInfo "Requested to use Hadrian" + liftE doHadrian + Just Make -> do + lift $ logInfo "Requested to use Make" + doMake + Nothing -> do + supportsHadrian <- liftE $ catchE @HadrianNotFound @'[HadrianNotFound] @'[] (\_ -> return False) + $ fmap (const True) + $ findHadrianFile (fromGHCupPath workdir) + if supportsHadrian + then do + lift $ logInfo "Detected Hadrian" + liftE doHadrian + else do + lift $ logInfo "Detected Make" + doMake ) 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. [] - liftIO $ B.writeFile (fromInstallDir ghcdir ghcUpSrcBuiltFile) bmk - case installDir of -- set and make symlinks for regular (non-isolated) installs GHCupInternal -> do diff --git a/lib/GHCup/List.hs b/lib/GHCup/List.hs index 3d38880..d1744bb 100644 --- a/lib/GHCup/List.hs +++ b/lib/GHCup/List.hs @@ -76,7 +76,6 @@ data ListResult = ListResult , lTag :: [Tag] , lInstalled :: Bool , lSet :: Bool -- ^ currently active version - , fromSrc :: Bool -- ^ compiled from source , lStray :: Bool -- ^ not in download info , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch , hlsPowered :: Bool @@ -169,7 +168,6 @@ listVersions lt' criteria hideOld showNightly days = do Just _ -> pure Nothing Nothing -> do lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget - fromSrc <- ghcSrcInstalled tver hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions pure $ Just $ ListResult { lTool = GHC @@ -213,7 +211,6 @@ listVersions lt' criteria hideOld showNightly days = do , lInstalled = True , lStray = isNothing (Map.lookup ver avTools) , lNoBindist = False - , fromSrc = False -- actually, we don't know :> , hlsPowered = False , lReleaseDay = Nothing , .. @@ -248,7 +245,6 @@ listVersions lt' criteria hideOld showNightly days = do , lInstalled = True , lStray = isNothing (Map.lookup ver avTools) , lNoBindist = False - , fromSrc = False -- actually, we don't know :> , hlsPowered = False , lReleaseDay = Nothing , .. @@ -284,7 +280,6 @@ listVersions lt' criteria hideOld showNightly days = do , lInstalled = True , lStray = isNothing (Map.lookup ver avTools) , lNoBindist = False - , fromSrc = False -- actually, we don't know :> , hlsPowered = False , lReleaseDay = Nothing , .. @@ -306,7 +301,6 @@ listVersions lt' criteria hideOld showNightly days = do , lTag = maybe (if isOld then [Old] else []) _viTags listVer , lCross = Nothing , lTool = GHCup - , fromSrc = False , lStray = isNothing listVer , lSet = True , lInstalled = True @@ -340,7 +334,6 @@ listVersions lt' criteria hideOld showNightly days = do lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver) lInstalled <- ghcInstalled tver - fromSrc <- ghcSrcInstalled tver hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions) pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. } Cabal -> do @@ -351,7 +344,6 @@ listVersions lt' criteria hideOld showNightly days = do , lCross = Nothing , lTag = _viTags , lTool = t - , fromSrc = False , lStray = False , hlsPowered = False , lReleaseDay = _viReleaseDay @@ -364,7 +356,6 @@ listVersions lt' criteria hideOld showNightly days = do , lTag = _viTags , lCross = Nothing , lTool = t - , fromSrc = False , lStray = False , lNoBindist = False , hlsPowered = False @@ -379,7 +370,6 @@ listVersions lt' criteria hideOld showNightly days = do , lCross = Nothing , lTag = _viTags , lTool = t - , fromSrc = False , lStray = False , hlsPowered = False , lReleaseDay = _viReleaseDay @@ -393,7 +383,6 @@ listVersions lt' criteria hideOld showNightly days = do , lCross = Nothing , lTag = _viTags , lTool = t - , fromSrc = False , lStray = False , hlsPowered = False , lReleaseDay = _viReleaseDay diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 475ea6f..5f0e7f2 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -288,13 +288,6 @@ ghcInstalled ver = do 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. ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) => 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 --- | This file, when residing in @~\/.ghcup\/ghc\/\\/@ 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. make :: ( MonadThrow m