cabal-clean 0.1.20220814 → 0.2.20220819
raw patch · 9 files changed
+118/−22 lines, 9 filesdep +filemanipdep +silently
Dependencies added: filemanip, silently
Files
- CHANGELOG.md +5/−0
- README.md +7/−3
- cabal-clean.cabal +5/−2
- src/DiscoverGHCs.hs +51/−0
- src/Main.hs +22/−10
- src/Options.hs +3/−0
- src/Structure.hs +9/−6
- src/Types.hs +6/−0
- src/Util.hs +10/−1
CHANGELOG.md view
@@ -1,3 +1,8 @@+0.2.20220819+------------++Also remove builds with GHCs which are no longer on the PATH.+ 0.1.20220814 ------------
README.md view
@@ -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`.
cabal-clean.cabal view
@@ -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 <andreas.abel@cse.gu.se>-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
+ src/DiscoverGHCs.hs view
@@ -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
src/Main.hs view
@@ -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.)" ] ]
src/Options.hs view
@@ -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]
src/Structure.hs view
@@ -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.
src/Types.hs view
@@ -46,3 +46,9 @@ parseVersionString :: VersionString -> Maybe NumericVersion parseVersionString = mapM readMaybe . splitWhen (== '.')++printNumericVersion :: NumericVersion -> VersionString+printNumericVersion = intercalate "." . map show++toNumericVersion :: CompilerVersion -> NumericVersion+toNumericVersion = uncurry (++)
src/Util.hs view
@@ -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)