diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.2.20220819 +------------ + +Also remove builds with GHCs which are no longer on the PATH. + 0.1.20220814 ------------ diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -28,10 +28,11 @@ --- 162M dist-newstyle/build/x86_64-osx/ghc-9.0.1/$MY_PROJECT-2.9.2 +++ 135M dist-newstyle/build/x86_64-osx/ghc-7.10.3/$MY_PROJECT-2.9.3 --- 70M dist-newstyle/build/x86_64-osx/ghc-8.10.4/$MY_PROJECT-2.9.3 -+++ 145M dist-newstyle/build/x86_64-osx/ghc-8.10.5/$MY_PROJECT-2.9.3 -+++ 159M dist-newstyle/build/x86_64-osx/ghc-9.0.1/$MY_PROJECT-2.9.3 ++++ 145M dist-newstyle/build/x86_64-osx/ghc-8.10.7/$MY_PROJECT-2.9.3 +--- 159M dist-newstyle/build/x86_64-osx/ghc-9.0.1/$MY_PROJECT-2.9.3 ``` -The superseded ones, printed in red and prefixed by dashes (`---`), +The superseded ones (assuming `ghc-9.0.1` is not on the `PATH`), +printed in red and prefixed by dashes (`---`), can then be removed by: cabal-clean --delete @@ -61,6 +62,9 @@ - Keep only the most recent `$VERSION` of the package. - Keep only the most recent major versions of `$HC`. + +- Keep only versions build with a `$HC` which is still on the PATH + (since version 0.2). - Assume a monopoly of GHC, ignoring other Haskell compilers, so only treat `$HC`s of the form `ghc-$GHCVER`. diff --git a/cabal-clean.cabal b/cabal-clean.cabal --- a/cabal-clean.cabal +++ b/cabal-clean.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.10 name: cabal-clean -version: 0.1.20220814 +version: 0.2.20220819 synopsis: Remove outdated cabal build artefacts from `dist-newstyle`. description: Simple command line tool to remove cabal build artefacts @@ -15,7 +15,7 @@ author: Andreas Abel maintainer: Andreas Abel -copyright: Andreas Abel, 2021 +copyright: Andreas Abel, 2021, 2022 category: Development build-type: Simple @@ -42,6 +42,7 @@ main-is: Main.hs other-modules: + DiscoverGHCs License Options Structure @@ -56,6 +57,7 @@ , containers >= 0.5.8 , directory -- , directory >= 1.2.6.2 && < 1.4 + , filemanip >= 0.3.6.3 , filepath -- , filepath == 1.4.* , mtl @@ -64,6 +66,7 @@ -- pretty-terminal-0.1.0.0 has base >= 4.9 , pretty-terminal , process + , silently >= 1.2.5.2 , split , string-qq diff --git a/src/DiscoverGHCs.hs b/src/DiscoverGHCs.hs new file mode 100644 --- /dev/null +++ b/src/DiscoverGHCs.hs @@ -0,0 +1,51 @@ +-- | Discover installed GHCs. + +module DiscoverGHCs where + +import Control.Exception + ( evaluate ) +import System.FilePath + ( getSearchPath, stripExtension, takeFileName ) +import System.FilePath.Find + ( find, anyPerms, depth, fileName, (<=?), (~~?), (&&?) ) +import System.IO.Silently + ( hSilence ) + +import Util + +import Options +import Types + +-- | Discover executables ghc-VERSION on the PATH. + +discoverGHCs :: Options -> IO [CompilerVersion] +discoverGHCs opts = do + + -- Get PATH. + path <- getSearchPath + + chatLines opts $ "PATH:" : map ("- " ++) path + + -- Look for ghc-* executables on PATH. + ghcs <- hSilence [stderr] $ do -- Silence warnings about broken symlinks produced by @find@. + evaluate =<< do -- Needed under Windows, otherwise warnings are raised too lazily + -- and not caught by @hSilence@. + concat <$> mapM (find recursionP filterP) path + + chatLines opts $ "GHCs on PATH:" : map ("- " ++) ghcs + + -- Parse results into @[CompilerVersion]@. + let versions = sort $ mapMaybe (parseCompilerString . stripExe . takeFileName) ghcs + + chatLines opts $ "Installed GHCs:" : + map (("- " ++) . printNumericVersion . toNumericVersion) versions + + return versions + + where + -- Never recurse into subdirectories. + recursionP = depth <=? 0 + -- Find executables named @ghc-[0-9]*@. + filterP = fileName ~~? "ghc-[0-9]*" &&? anyPerms 0111 + -- Remove a potential "exe" extension. + stripExe file = fromMaybe file $ stripExtension "exe" file diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -20,12 +20,15 @@ import System.Console.Pretty ( supportsPretty ) +import Util + +import DiscoverGHCs + ( discoverGHCs ) import License ( copyright, license ) import Options import Structure ( Entry(..), foldMapEntry, getBuildTree, markObsolete, printBuildTree ) -import Util import Version self :: String @@ -46,6 +49,9 @@ -- print opts let buildDir = optRoot "build" + -- Discover installed GHCs. + ghcs <- discoverGHCs opts + -- Get build tree. chatLn opts $ unwords [ "Reading", buildDir, "..." ] @@ -55,17 +61,21 @@ (tree0, warns) <- getBuildTree buildDir forM_ warns $ putStrLn . ("warning: " ++) - let tree = markObsolete tree0 + -- Mark superseded builds as obsolete. + -- If no installed GHCs could be found, assume a misconfiguration and + -- do not use installed GHCs as criterion. + let keep = if null ghcs then const True else hasElem ghcs + let tree = markObsolete keep tree0 printBuildTree opts tree - -- Count obsolete directories + -- Count obsolete directories. let nObs :: Integer nObs = getSum $ foldMapEntry ((\ x -> if x then Sum 1 else Sum 0) . obsolete) tree if nObs <= 0 then putStrLn ("Nothing to clean!") else if not optDelete then putStrLn $ unwords [ show nObs, "directories can be removed (supply option --remove)." ] - -- Remove obsolete directories + -- Remove obsolete directories. else do putStrLn $ unwords [ "Removing", show nObs, "obsolete directories..." ] flip foldMapEntry tree $ \ (Entry dir obsolete) -> do @@ -161,18 +171,20 @@ , show defaultRoot , ")." ] - , unwords - [ "A package build is considered superseded if there is a local build" - , "of either a newer version of the package or with a newer minor version" - , "of the Haskell compiler." - ] + , "" + , "A package build is considered superseded if one of the following conditions is met:" + , "- It was build with a Haskell compiler that cannot be found on the system PATH." + , "- There is a build of a newer version of the package." + , "- There is a build with a newer minor version of the Haskell compiler." + , "" + , "Limitation: Only GHC is recognized as Haskell compiler, and only in the form 'ghc-VERSION' (not just 'ghc')." ] footer = Just $ vcat $ map (text . unwords) [ [ unwords ["Without option --delete,", self, "does not actually clean out anything,"] , "just shows prefixed with '---' and in red what would be removed and prefixed with '+++' and in green what is kept." ] , [ "" ] - , [ "Warning: there is check whether the to-be-deleted contents are actually garbage." + , [ "Warning: there is no check whether the to-be-deleted contents are actually garbage." , "(E.g., there could be symlinks to executables stored there.)" ] ] diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -35,6 +35,9 @@ chatLn :: Options -> String -> IO () chatLn = chatGen $ hPutStrLn stderr +chatLines :: Options -> [String] -> IO () +chatLines = mapM_ . chatGen (hPutStrLn stderr) + chatGen :: (String -> IO ()) -> Options -> String -> IO () chatGen prt o msg = when (optVerbose o) $ prt $ styleOpt o Faint $ unwords ["info:", msg] diff --git a/src/Structure.hs b/src/Structure.hs --- a/src/Structure.hs +++ b/src/Structure.hs @@ -114,14 +114,14 @@ -- | Mark entries that are superseded by either a new package version -- or a new compiler minor version. -markObsolete :: BuildTree -> BuildTree -markObsolete = +markObsolete :: (CompilerVersion -> Bool) -> BuildTree -> BuildTree +markObsolete keep = -- for each Package, from highest to lowest PackageVersion: modifyBuildTree $ fmap $ modifyDesc $ modifyCons -- keep the highest PackageVersion, but iterate through GHC MinorVersion - (second $ fmap $ fmap $ modifyDesc $ modifyCons - -- keep the highest MinorVersion - id + (second $ fmap $ Map.mapWithKey $ \ major -> modifyDesc $ modifyCons + -- keep the highest MinorVersion if permitted by predicate @keep@ + (\ (minor, entry) -> (minor, setEntryObsolete (not $ keep (major, minor)) entry)) -- mark lower MinorVersion as obsolete (map $ second markEntryObsolete)) -- mark lower PackageVersion as obsolete @@ -132,7 +132,10 @@ -- mapDesc f = Map.fromDescList . map (second f) . Map.toDescList markEntryObsolete :: Entry -> Entry -markEntryObsolete (Entry dir _) = Entry dir True +markEntryObsolete = setEntryObsolete True + +setEntryObsolete :: Bool -> Entry -> Entry +setEntryObsolete obsolete (Entry dir _) = Entry dir obsolete -- | Remove directories marked as obsolete. diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -46,3 +46,9 @@ parseVersionString :: VersionString -> Maybe NumericVersion parseVersionString = mapM readMaybe . splitWhen (== '.') + +printNumericVersion :: NumericVersion -> VersionString +printNumericVersion = intercalate "." . map show + +toNumericVersion :: CompilerVersion -> NumericVersion +toNumericVersion = uncurry (++) diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -10,7 +10,7 @@ import Data.Bifunctor as X import Data.Char as X (isSpace) import Data.Function as X (on) -import Data.List as X (findIndex, findIndices, intercalate) +import Data.List as X (findIndex, findIndices, intercalate, sort) import Data.List.Split as X (splitWhen) import Data.Maybe as X import Data.Map as X (Map) @@ -26,6 +26,8 @@ import Text.Read as X (readMaybe) +import qualified Data.Set as Set + (<&>) :: Functor f => f a -> (a -> b) -> f b (<&>) = flip (<$>) @@ -54,3 +56,10 @@ -- UNUSED modifyTail :: ([a] -> [a]) -> [a] -> [a] modifyTail = modifyCons id + +-- | Like 'Data.List.elem', but turns list into a 'Set', to speed up subsequent lookups. +-- +-- Use partially applied, e.g. @hasElem xs :: a -> Bool@. +{-# INLINE hasElem #-} +hasElem :: Ord a => [a] -> a -> Bool +hasElem xs = (`Set.member` Set.fromList xs)