WIP unregister-broken command #1811

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)

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 =

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

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