diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index a84822ec39..5916948146 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -495,7 +495,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do , ")" ] ] - unregisterGhcPkgId eeEnvOverride wc cv localDB id' ident + unregisterGhcPkgId eeEnvOverride wc cv [localDB] id' ident liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap -> foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan) diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 30e97923e3..8ab14d4075 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -5,6 +5,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -fno-warn-unused-do-bind #-} -- | Functions for the GHC package database. @@ -14,9 +16,11 @@ module Stack.GhcPkg ,EnvOverride ,envHelper ,createDatabase + ,unregisterGhcPkgName ,unregisterGhcPkgId ,getCabalPkgVer ,ghcPkgExeName + ,ghcPkgCheck ,mkGhcPackagePath) where @@ -29,9 +33,11 @@ import qualified Data.ByteString.Char8 as S8 import Data.Either import Data.List import Data.Maybe +import Data.Maybe.Extra (mapMaybeM) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Error (lenientDecode) import Path (Path, Abs, Dir, toFilePath, parent) import Path.Extra (toFilePathNoTrailingSep) import Path.IO @@ -137,16 +143,26 @@ findGhcPkgVersion menv wc pkgDbs name = do Just !v -> return (parseVersion v) _ -> return Nothing +unregisterGhcPkgName :: (MonadIO m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) + => EnvOverride + -> WhichCompiler + -> [Path Abs Dir] -- ^ package databases + -> PackageName + -> m () +unregisterGhcPkgName menv wc pkgDbs pkgName = + either throwM ($logDebug . T.decodeUtf8With lenientDecode) =<< + ghcPkg menv wc pkgDbs ["unregister", "--user", "--force", packageNameString pkgName] + unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) => EnvOverride -> WhichCompiler -> CompilerVersion - -> Path Abs Dir -- ^ package database + -> [Path Abs Dir] -- ^ package databases -> GhcPkgId -> PackageIdentifier -> m () -unregisterGhcPkgId menv wc cv pkgDb gid ident = do - eres <- ghcPkg menv wc [pkgDb] args +unregisterGhcPkgId menv wc cv pkgDbs gid ident = do + eres <- ghcPkg menv wc pkgDbs args case eres of Left e -> $logWarn $ T.pack $ show e Right _ -> return () @@ -170,6 +186,28 @@ getCabalPkgVer menv wc = do cabalPackageName maybe (throwM $ Couldn'tFindPkgId cabalPackageName) return mres +ghcPkgCheck :: (MonadIO m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) + => EnvOverride + -> WhichCompiler + -> [Path Abs Dir] -- ^ package databases + -> m [PackageName] -- ^ broken packages +ghcPkgCheck menv wc pkgDbs = do + eres <- ghcPkg menv wc pkgDbs ["check"] + case eres of + Left err -> throwM err + Right bs -> mapMaybeM toBrokenPackage (S8.splitWith (`elem` ("\n\r" :: [Char])) bs) + where + toBrokenPackage ( T.stripPrefix "There are problems in package " . T.decodeUtf8 + -> Just (T.stripSuffix ":" -> Just name) + ) = do + case parsePackageName name of + -- TODO: custom error + Left (fromException -> Just (err :: PackageNameParseFail)) -> + error ("Error parsing package name from 'ghc-pkg check' output: " ++ show err) + Left err -> throwM err + Right x -> return (Just x) + toBrokenPackage _ = return Nothing + -- | Get the value for GHC_PACKAGE_PATH mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text mkGhcPackagePath locals localdb deps extras globaldb = diff --git a/src/main/Main.hs b/src/main/Main.hs index 8aba5e148d..6cde43c55d 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -12,9 +12,9 @@ module Main (main) where -import Control.Exception import qualified Control.Exception.Lifted as EL import Control.Monad hiding (mapM, forM) +import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (ask, asks,local,runReaderT) @@ -39,21 +39,15 @@ import Data.Typeable (Typeable) import Data.Version (showVersion) import System.Process.Read import System.Process.Run -#ifdef USE_GIT_INFO -import Development.GitRev (gitCommitCount, gitHash) -#endif import Distribution.System (buildArch, buildPlatform) import Distribution.Text (display) import GHC.IO.Encoding (mkTextEncoding, textEncodingName) import Lens.Micro import Network.HTTP.Client import Options.Applicative -import Options.Applicative.Help (errorHelp, stringChunk, vcatChunks) import Options.Applicative.Builder.Extra import Options.Applicative.Complicated -#ifdef USE_GIT_INFO -import Options.Applicative.Simple (simpleVersion) -#endif +import Options.Applicative.Help (errorHelp, stringChunk, vcatChunks) import Options.Applicative.Types (readerAsk, ParserHelp(..)) import Path import Path.Extra (toFilePathNoTrailingSep) @@ -71,14 +65,14 @@ import Stack.Coverage import qualified Stack.Docker as Docker import Stack.Dot import Stack.Exec -import qualified Stack.Nix as Nix import Stack.Fetch import Stack.FileWatch -import Stack.GhcPkg (getGlobalDB, mkGhcPackagePath) +import Stack.GhcPkg (getGlobalDB, mkGhcPackagePath, ghcPkgCheck, unregisterGhcPkgName) import Stack.Ghci import qualified Stack.Image as Image import Stack.Init import Stack.New +import qualified Stack.Nix as Nix import Stack.Options import Stack.Package (findOrGenerateCabalFile) import qualified Stack.PackageIndex @@ -98,6 +92,11 @@ import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclu import System.FilePath (pathSeparator, searchPathSeparator) import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, Handle, hGetEncoding, hSetEncoding) +#ifdef USE_GIT_INFO +import Development.GitRev (gitCommitCount, gitHash) +import Options.Applicative.Simple (simpleVersion) +#endif + -- | Change the character encoding of the given Handle to transliterate -- on unsupported characters instead of throwing an exception hSetTranslit :: Handle -> IO () @@ -153,7 +152,7 @@ main = do eGlobalRun <- try $ commandLineHandler progName False case eGlobalRun of Left (exitCode :: ExitCode) -> do - throwIO exitCode + throwM exitCode Right (globalMonoid,run) -> do let global = globalOptsFromMonoid isTerminal globalMonoid when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString' @@ -162,7 +161,7 @@ main = do expectVersion' <- parseVersionFromString expectVersion if checkVersion MatchMinor expectVersion' (fromCabalVersion Meta.version) then return () - else throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version) + else throwM $ InvalidReExecVersion expectVersion (showVersion Meta.version) _ -> return () run global `catch` \e -> -- This special handler stops "stack: " from being printed before the @@ -376,6 +375,10 @@ commandLineHandler progName isInterpreter = complicatedOptions "Query general build information (experimental)" queryCmd (many $ strArgument $ metavar "SELECTOR...") + addCommand' "unregister-broken" + "Unregister broken packages" + unregisterBrokenCmd + (pure ()) addSubCommands' "ide" "IDE-specific commands" @@ -1230,7 +1233,7 @@ hoogleCmd (args,setup,rebuild) go = withBuildConfig go pathToHaddocks (\(e :: ExitCode) -> case e of ExitSuccess -> resetExeCache menv - _ -> throwIO e)) + _ -> EL.throwIO e)) runHoogle :: [String] -> StackT EnvConfig IO () runHoogle hoogleArgs = do config <- asks getConfig @@ -1429,6 +1432,18 @@ queryCmd selectors go = withBuildConfig go $ queryBuildInfo $ map T.pack selecto hpcReportCmd :: HpcReportOpts -> GlobalOpts -> IO () hpcReportCmd hropts go = withBuildConfig go $ generateHpcReportForTargets hropts +unregisterBrokenCmd :: () -> GlobalOpts -> IO () +unregisterBrokenCmd () go = withBuildConfig go $ do + menv <- getMinimalEnvOverride + wc <- getWhichCompiler + brokenPackages <- ghcPkgCheck menv wc [] + if null brokenPackages + then $logInfo "'ghc-pkg check' didn't find any broken packages." + else do + $logInfo $ "'ghc-pkg check' reported the following packages as broken: " <> T.pack (show brokenPackages) + $logInfo $ "Unregistering these packages..." + mapM_ (unregisterGhcPkgName menv wc []) brokenPackages + data MainException = InvalidReExecVersion String String deriving (Typeable) instance Exception MainException diff --git a/stack.cabal b/stack.cabal index 30baba933f..3d03d20654 100644 --- a/stack.cabal +++ b/stack.cabal @@ -257,6 +257,7 @@ executable stack , stack , text >= 1.2.0.4 , transformers >= 0.3.0.0 && < 0.6 + , exceptions default-language: Haskell2010 if os(windows) build-depends: Win32