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

Add logging when unregistering a package

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

18
Stackage/GhcPkg.hs
View File

@ -1,7 +1,10 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-- | General commands related to ghc-pkg. -- | General commands related to ghc-pkg.
module Stackage.GhcPkg where module Stackage.GhcPkg
( setupPackageDatabase
) where
import Data.Conduit import Data.Conduit
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
@ -23,16 +26,17 @@ 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 -> FilePath -- ^ documentation root
-> (ByteString -> IO ()) -- ^ logging
-> 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 docDir toInstall = do setupPackageDatabase mdb docDir log' toInstall = do
registered1 <- getRegisteredPackages flags registered1 <- getRegisteredPackages flags
forM_ registered1 $ \pi@(PackageIdentifier name version) -> forM_ registered1 $ \pi@(PackageIdentifier name version) ->
case lookup name toInstall of case lookup name toInstall of
Just version' | version /= version' -> unregisterPackage docDir flags pi Just version' | version /= version' -> unregisterPackage log' docDir flags pi
_ -> return () _ -> return ()
broken <- getBrokenPackages flags broken <- getBrokenPackages flags
forM_ broken $ unregisterPackage docDir flags forM_ broken $ unregisterPackage log' docDir flags
foldMap (\(PackageIdentifier name _) -> singletonSet name) foldMap (\(PackageIdentifier name _) -> singletonSet name)
<$> getRegisteredPackages flags <$> getRegisteredPackages flags
where where
@ -73,9 +77,11 @@ parsePackageIdent = fmap fst .
readP_to_S parse . T.unpack readP_to_S parse . T.unpack
-- | Unregister a package. -- | Unregister a package.
unregisterPackage :: FilePath -- ^ doc directory unregisterPackage :: (ByteString -> IO ()) -- ^ log func
-> FilePath -- ^ doc directory
-> [String] -> PackageIdentifier -> IO () -> [String] -> PackageIdentifier -> IO ()
unregisterPackage docDir flags ident@(PackageIdentifier name _) = do unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do
log' $ "Unregistering " ++ encodeUtf8 (display ident)
void (readProcessWithExitCode void (readProcessWithExitCode
"ghc-pkg" "ghc-pkg"
("unregister": flags ++ ["--force", unpack $ display name]) ("unregister": flags ++ ["--force", unpack $ display name])

1
Stackage/PerformBuild.hs
View File

@ -195,6 +195,7 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
registeredPackages <- setupPackageDatabase registeredPackages <- setupPackageDatabase
(pbDatabase pb) (pbDatabase pb)
(pbDocDir pb) (pbDocDir pb)
pbLog
(ppVersion <$> bpPackages pbPlan) (ppVersion <$> bpPackages pbPlan)
forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages