haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-03-11 11:16:34 +01:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

shake: Clean up broken packages

Browse Source
This commit is contained in:
Chris Done 2015-01-15 21:03:29 +01:00
parent 16d58d5887
commit 2cc33a8545
1 changed files with 51 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
Stackage/ShakeBuild.hs
View File

@ -349,6 +349,12 @@ pbLibDir shakeDir = shakeDir <//> "lib"
pbDataDir shakeDir = shakeDir <//> "share" pbDataDir shakeDir = shakeDir <//> "share"
pbDocDir shakeDir = shakeDir <//> "doc" pbDocDir shakeDir = shakeDir <//> "doc"
-- | Reason for purging a package.
data PurgeReason
= NoLongerIncluded
| Replaced Version
| Broken
-- | Clean up old versions of packages that are no longer in use. -- | Clean up old versions of packages that are no longer in use.
cleanOldPackages :: PerformBuild -> FilePath -> IO () cleanOldPackages :: PerformBuild -> FilePath -> IO ()
cleanOldPackages pb shakeDir = do cleanOldPackages pb shakeDir = do
@ -360,32 +366,57 @@ cleanOldPackages pb shakeDir = do
Just version' Just version'
| version' == version -> | version' == version ->
return () return ()
Just newVersion -> purgePackage shakeDir name version (Just newVersion) Just newVersion -> purgePackage
Nothing -> purgePackage shakeDir name version Nothing shakeDir
name
version
(Replaced newVersion)
Nothing -> purgePackage shakeDir name version NoLongerIncluded
broken <- getBrokenPackages shakeDir
forM_
broken
(\(PackageIdentifier name version) ->
purgePackage shakeDir name version Broken)
where versions = (M.map ppVersion . bpPackages . pbPlan) pb where versions = (M.map ppVersion . bpPackages . pbPlan) pb
-- | Purge the given package and version. -- | Purge the given package and version.
purgePackage :: FilePath -> PackageName -> Version -> Maybe Version -> IO () purgePackage :: FilePath -> PackageName -> Version -> PurgeReason -> IO ()
purgePackage shakeDir name version newVersion = do purgePackage shakeDir name version reason = do
putStrLn $ "Cleaning up unused package: " ++ ident ++ " (" ++ reason ++ ")" putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... "
unregister unregister
delete delete
where reason = putStrLn "done."
case newVersion of where showReason =
Just version' -> "replaced by " ++ ordinal ++ " " ++ display version' case reason of
Replaced version' -> "replaced by " ++ ordinal ++ " " ++ display version'
where ordinal | version' > version = "newer" where ordinal | version' > version = "newer"
| otherwise = "older" | otherwise = "older"
Nothing -> "no longer included" NoLongerIncluded -> "no longer included"
Broken -> "broken"
ident = nameVer name version ident = nameVer name version
unregister = void $ unregister = do
readProcessWithExitCode void (readProcessWithExitCode
"ghc-pkg" "ghc-pkg"
["unregister", "-f", buildDatabase shakeDir, "--force", ident] ["unregister", "-f", buildDatabase shakeDir, "--force", ident]
"" "")
void (readProcessWithExitCode
"ghc-pkg"
["recache", "-f", buildDatabase shakeDir]
"")
delete = removeDirectoryRecursive $ delete = removeDirectoryRecursive $
pkgDir shakeDir name version pkgDir shakeDir name version
-- | Get globally available packages. -- | Get broken packages.
getBrokenPackages :: FilePath -> IO [PackageIdentifier]
getBrokenPackages shakeDir = do
(_,ps) <- sourceProcessWithConsumer
(proc'
"ghc-pkg"
["check", "--simple-output", "-f", buildDatabase shakeDir])
(CT.decodeUtf8 $= CT.lines $= CL.consume)
return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))
-- | Get available packages.
getRegisteredPackages :: FilePath -> IO [PackageIdentifier] getRegisteredPackages :: FilePath -> IO [PackageIdentifier]
getRegisteredPackages shakeDir = do getRegisteredPackages shakeDir = do
(_,ps) <- sourceProcessWithConsumer (_,ps) <- sourceProcessWithConsumer