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

Delete old Haddocks when unregistering

Browse Source
This commit is contained in:
Michael Snoyman 2015-03-12 17:00:56 +02:00
parent f5bd0c777d
commit e75b014b8b
2 changed files with 13 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
Stackage/GhcPkg.hs
View File

@ -18,19 +18,21 @@ import qualified Filesystem.Path.CurrentOS as FP
import Data.Map (Map) import Data.Map (Map)
import Data.Version (Version) import Data.Version (Version)
import Stackage.Prelude import Stackage.Prelude
import Filesystem (removeTree)
setupPackageDatabase setupPackageDatabase
:: Maybe FilePath -- ^ database location, Nothing if using global DB :: Maybe FilePath -- ^ database location, Nothing if using global DB
-> FilePath -- ^ documentation root
-> Map PackageName Version -- ^ packages and versions to be installed -> Map PackageName Version -- ^ packages and versions to be installed
-> IO (Set PackageName) -- ^ packages remaining in the database after cleanup -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup
setupPackageDatabase mdb toInstall = do setupPackageDatabase mdb docDir toInstall = do
registered1 <- getRegisteredPackages flags registered1 <- getRegisteredPackages flags
forM_ registered1 $ \(PackageIdentifier name version) -> forM_ registered1 $ \pi@(PackageIdentifier name version) ->
case lookup name toInstall of case lookup name toInstall of
Just version' | version /= version' -> unregisterPackage flags name Just version' | version /= version' -> unregisterPackage docDir flags pi
_ -> return () _ -> return ()
broken <- getBrokenPackages flags broken <- getBrokenPackages flags
forM_ broken $ \(PackageIdentifier name _) -> unregisterPackage flags name forM_ broken $ unregisterPackage docDir flags
foldMap (\(PackageIdentifier name _) -> singletonSet name) foldMap (\(PackageIdentifier name _) -> singletonSet name)
<$> getRegisteredPackages flags <$> getRegisteredPackages flags
where where
@ -71,9 +73,12 @@ parsePackageIdent = fmap fst .
readP_to_S parse . T.unpack readP_to_S parse . T.unpack
-- | Unregister a package. -- | Unregister a package.
unregisterPackage :: [String] -> PackageName -> IO () unregisterPackage :: FilePath -- ^ doc directory
unregisterPackage flags ident = do -> [String] -> PackageIdentifier -> IO ()
unregisterPackage docDir flags ident@(PackageIdentifier name _) = do
void (readProcessWithExitCode void (readProcessWithExitCode
"ghc-pkg" "ghc-pkg"
("unregister": flags ++ ["--force", unpack $ display ident]) ("unregister": flags ++ ["--force", unpack $ display name])
"") "")
void $ tryIO $ removeTree $ docDir </> fpFromText (display ident)

2
Stackage/PerformBuild.hs
View File

@ -194,6 +194,7 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
registeredPackages <- setupPackageDatabase registeredPackages <- setupPackageDatabase
(pbDatabase pb) (pbDatabase pb)
(pbDocDir pb)
(ppVersion <$> bpPackages pbPlan) (ppVersion <$> bpPackages pbPlan)
forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages
@ -366,7 +367,6 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
unless (pname `member` registeredPackages) $ withConfiged $ do unless (pname `member` registeredPackages) $ withConfiged $ do
deletePreviousResults pb pname deletePreviousResults pb pname
-- FIXME delete old Haddocks?
log' $ "Building " ++ namever log' $ "Building " ++ namever
run "cabal" ["build"] run "cabal" ["build"]