Resolve #6355: Fix most incomplete-uni-patterns

Or replace

    Just foo = rhs

with

    foo = fromMaybe (error "...") rhs

which there are plenty. I didn't tried to refactor these errors away,
let cabal panic, if it hits them.

Author: phadej

Cabal/Cabal.cabal

@@ -291,7 +291,7 @@ library
   else
     build-depends: unix  >= 2.6.0.0 && < 2.8
 
-  ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs
+  ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns
   if impl(ghc >= 8.0)
     ghc-options: -Wcompat -Wnoncanonical-monad-instances
 

Cabal/Distribution/Backpack/Configure.hs

@@ -162,7 +162,8 @@ toComponentLocalBuildInfos
                        . map Right
                        $ graph
         combined_graph = Graph.unionRight external_graph internal_graph
-        Just local_graph = Graph.closure combined_graph (map nodeKey graph)
+        local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing")
+                    $ Graph.closure combined_graph (map nodeKey graph)
         -- The database of transitively reachable installed packages that the
         -- external components the package (as a whole) depends on.  This will be
         -- used in several ways:

Cabal/Distribution/Compat/Binary.hs

@@ -18,12 +18,7 @@ module Distribution.Compat.Binary
 #endif
        ) where
 
-import Control.Exception (catch, evaluate)
-#if __GLASGOW_HASKELL__ >= 711
-import Control.Exception (pattern ErrorCall)
-#else
-import Control.Exception (ErrorCall(..))
-#endif
+import Control.Exception (ErrorCall (..), catch, evaluate)
 import Data.ByteString.Lazy (ByteString)
 
 #if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)
@@ -67,5 +62,10 @@ encodeFile f = BSL.writeFile f . encode
 
 decodeOrFailIO :: Binary a => ByteString -> IO (Either String a)
 decodeOrFailIO bs =
-  catch (evaluate (decode bs) >>= return . Right)
-  $ \(ErrorCall str) -> return $ Left str
+  catch (evaluate (decode bs) >>= return . Right) handler
+  where
+#if MIN_VERSION_base(4,9,0)
+    handler (ErrorCallWithLocation str _) = return $ Left str
+#else
+    handler (ErrorCall str) = return $ Left str
+#endif

Cabal/Distribution/Parsec.hs

@@ -379,7 +379,9 @@ escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P.<?> "escape c
                                      nomore :: m ()
                                      nomore = P.notFollowedBy anyd <|> toomuch
 
-                                     (low, ex : high) = splitAt bd dps
+                                     (low, ex, high) = case splitAt bd dps of
+                                        (low', ex' : high') -> (low', ex', high')
+                                        (_, _)              -> error "escapeCode: Logic error"
                                   in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore
                                      <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds))
                                      <|> if not (null bds)

Cabal/Distribution/Simple/Build/Macros.hs

@@ -109,9 +109,9 @@ generateToolVersionMacros progs = concat
   ++ generateMacros "TOOL_" progname version
   | prog <- progs
   , isJust . programVersion $ prog
-  , let progid       = programId prog ++ "-" ++ prettyShow version
-        progname     = map fixchar (programId prog)
-        Just version = programVersion prog
+  , let progid   = programId prog ++ "-" ++ prettyShow version
+        progname = map fixchar (programId prog)
+        version  = fromMaybe version0 (programVersion prog)
   ]
 
 -- | Common implementation of 'generatePackageVersionMacros' and
@@ -131,7 +131,11 @@ generateMacros macro_prefix name version =
     ]
   ,"\n"]
   where
-    (major1:major2:minor:_) = map show (versionNumbers version ++ repeat 0)
+    (major1,major2,minor) = case map show (versionNumbers version) of
+        []        -> ("0", "0", "0")
+        [x]       -> (x,   "0", "0")
+        [x,y]     -> (x,   y,   "0")
+        (x:y:z:_) -> (x,   y,   z)
 
 -- | Generate the @CURRENT_COMPONENT_ID@ definition for the component ID
 --   of the current package.

Cabal/Distribution/Simple/BuildTarget.hs

@@ -58,6 +58,7 @@ import qualified Distribution.Compat.CharParsing as P
 
 import Control.Monad ( msum )
 import Data.List ( stripPrefix, groupBy, partition )
+import qualified Data.List.NonEmpty as NE
 import Data.Either ( partitionEithers )
 import System.FilePath as FilePath
          ( dropExtension, normalise, splitDirectories, joinPath, splitPath
@@ -318,8 +319,9 @@ resolveBuildTarget pkg userTarget fexists =
 
   where
     classifyMatchErrors errs
-      | not (null expected) = let (things, got:_) = unzip expected in
-                              BuildTargetExpected userTarget things got
+      | Just expected' <- NE.nonEmpty expected
+                            = let (things, got:|_) = NE.unzip expected' in
+                              BuildTargetExpected userTarget (NE.toList things) got
       | not (null nosuch)   = BuildTargetNoSuch   userTarget nosuch
       | otherwise = error $ "resolveBuildTarget: internal error in matching"
       where

Cabal/Distribution/Simple/GHC.hs

@@ -317,7 +317,7 @@ guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram
 getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
 getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg
   where
-    Just version = programVersion ghcProg
+    version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg
     implInfo = ghcVersionImplInfo version
 
 -- | Given a single package DB, return all installed packages.
@@ -363,7 +363,7 @@ toPackageIndex verbosity pkgss progdb = do
   return $! mconcat indices
 
   where
-    Just ghcProg = lookupProgram ghcProgram progdb
+    ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb
 
 getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
 getLibDir verbosity lbi =
@@ -396,7 +396,7 @@ getUserPackageDB _verbosity ghcProg platform = do
     platformAndVersion = Internal.ghcPlatformAndVersionString
                            platform ghcVersion
     packageConfFileName = "package.conf.d"
-    Just ghcVersion = programVersion ghcProg
+    ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg
 
 checkPackageDbEnvVar :: Verbosity -> IO ()
 checkPackageDbEnvVar verbosity =
@@ -475,7 +475,7 @@ getInstalledPackagesMonitorFiles verbosity platform progdb =
       if isFileStyle then return path
                      else return (path </> "package.cache")
 
-    Just ghcProg = lookupProgram ghcProgram progdb
+    ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb
 
 
 -- -----------------------------------------------------------------------------
@@ -2032,9 +2032,9 @@ hcPkgInfo progdb = HcPkg.HcPkgInfo
   , HcPkg.suppressFilesCheck   = v >= [6,6]
   }
   where
-    v               = versionNumbers ver
-    Just ghcPkgProg = lookupProgram ghcPkgProgram progdb
-    Just ver        = programVersion ghcPkgProg
+    v          = versionNumbers ver
+    ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb
+    ver        = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg
 
 registerPackage
   :: Verbosity
@@ -2051,7 +2051,7 @@ pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
 pkgRoot verbosity lbi = pkgRoot'
    where
     pkgRoot' GlobalPackageDB =
-      let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
+      let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi)
       in  fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)
     pkgRoot' UserPackageDB = do
       appDir <- getAppUserDataDirectory "ghc"

Cabal/Distribution/Simple/GHCJS.hs

@@ -241,7 +241,7 @@ guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath
 getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
 getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg
   where
-    Just version = programVersion ghcjsProg
+    version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg
     implInfo = ghcVersionImplInfo version
 
 -- | Given a single package DB, return all installed packages.
@@ -275,7 +275,7 @@ toPackageIndex verbosity pkgss progdb = do
   return $! (mconcat indices)
 
   where
-    Just ghcjsProg = lookupProgram ghcjsProgram progdb
+    ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb
 
 getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
 getLibDir verbosity lbi =
@@ -307,7 +307,7 @@ getUserPackageDB _verbosity ghcjsProg platform = do
     platformAndVersion = Internal.ghcPlatformAndVersionString
                            platform ghcjsVersion
     packageConfFileName = "package.conf.d"
-    Just ghcjsVersion = programVersion ghcjsProg
+    ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg
 
 checkPackageDbEnvVar :: Verbosity -> IO ()
 checkPackageDbEnvVar verbosity =
@@ -360,7 +360,7 @@ getInstalledPackagesMonitorFiles verbosity platform progdb =
       if isFileStyle then return path
                      else return (path </> "package.cache")
 
-    Just ghcjsProg = lookupProgram ghcjsProgram progdb
+    ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb
 
 
 toJSLibName :: String -> String
@@ -1782,8 +1782,8 @@ hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcjsPkgProg
                                    }
   where
     v7_10 = mkVersion [7,10]
-    Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram progdb
-    Just ver          = programVersion ghcjsPkgProg
+    ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb
+    ver          = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg
 
 registerPackage
   :: Verbosity
@@ -1800,7 +1800,7 @@ pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
 pkgRoot verbosity lbi = pkgRoot'
    where
     pkgRoot' GlobalPackageDB =
-      let Just ghcjsProg = lookupProgram ghcjsProgram (withPrograms lbi)
+      let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi)
       in  fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg)
     pkgRoot' UserPackageDB = do
       appDir <- getAppUserDataDirectory "ghcjs"
@@ -1830,4 +1830,4 @@ runCmd progdb exe =
   )
   where
     script = exe <.> "jsexe" </> "all" <.> "js"
-    Just ghcjsProg = lookupProgram ghcjsProgram progdb
+    ghcjsProg = fromMaybe (error "GHCJS.runCmd: no ghcjs program") $ lookupProgram ghcjsProgram progdb

Cabal/Distribution/Simple/Haddock.hs

@@ -525,7 +525,11 @@ getGhcCppOpts haddockVersion bi =
     haddockVersionMacro  = "-D__HADDOCK_VERSION__="
                            ++ show (v1 * 1000 + v2 * 10 + v3)
       where
-        [v1, v2, v3] = take 3 $ versionNumbers haddockVersion ++ [0,0]
+        (v1, v2, v3) = case versionNumbers haddockVersion of
+            []        -> (0,0,0)
+            [x]       -> (x,0,0)
+            [x,y]     -> (x,y,0)
+            (x:y:z:_) -> (x,y,z)
 
 getGhcLibDir :: Verbosity -> LocalBuildInfo
              -> IO HaddockArgs

Cabal/Distribution/Simple/ShowBuildInfo.hs

@@ -56,6 +56,9 @@
 
 module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where
 
+import Distribution.Compat.Prelude
+import Prelude ()
+
 import qualified Distribution.Simple.GHC   as GHC
 import qualified Distribution.Simple.Program.GHC as GHC
 
@@ -122,7 +125,7 @@ mkBuildInfo pkg_descr lbi _flags targetsToBuild = info
       ]
       where
         bi = componentBuildInfo comp
-        Just comp = lookupComponent pkg_descr name
+        comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name
         compType = case comp of
           CLib _   -> "lib"
           CExe _   -> "exe"

Cabal/Distribution/Simple/Test/LibV09.hs

@@ -207,7 +207,9 @@ writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub
 writeSimpleTestStub t dir = do
     createDirectoryIfMissing True dir
     let filename = dir </> stubFilePath t
-        PD.TestSuiteLibV09 _ m = PD.testInterface t
+        m = case PD.testInterface t of
+            PD.TestSuiteLibV09 _  m' -> m'
+            _                        -> error "writeSimpleTestStub: invalid TestSuite passed"
     writeFile filename $ simpleTestStub m
 
 -- | Source code for library test suite stub executable

Cabal/Distribution/Simple/UHC.hs

@@ -116,9 +116,11 @@ getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath
 getGlobalPackageDir verbosity progdb = do
     output <- getDbProgramOutput verbosity
                 uhcProgram progdb ["--meta-pkgdir-system"]
-    -- call to "lines" necessary, because pkgdir contains an extra newline at the end
-    let [pkgdir] = lines output
+    -- we need to trim because pkgdir contains an extra newline at the end
+    let pkgdir = trimEnd output
     return pkgdir
+  where
+    trimEnd = reverse . dropWhile isSpace . reverse
 
 getUserPackageDir :: NoCallStackIO FilePath
 getUserPackageDir = do

Cabal/Distribution/Utils/Structured.hs

@@ -79,12 +79,7 @@ import Data.Word          (Word, Word16, Word32, Word64, Word8)
 
 import qualified Control.Monad.Trans.State.Strict as State
 
-import Control.Exception (catch, evaluate)
-#if __GLASGOW_HASKELL__ >= 711
-import Control.Exception (pattern ErrorCall)
-#else
-import Control.Exception (ErrorCall (..))
-#endif
+import Control.Exception (ErrorCall (..), catch, evaluate)
 
 import GHC.Generics
 
@@ -277,8 +272,13 @@ structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a))
 
 structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a)
 structuredDecodeOrFailIO bs =
-  catch (evaluate (structuredDecode bs) >>= return . Right)
-  $ \(ErrorCall str) -> return $ Left str
+    catch (evaluate (structuredDecode bs) >>= return . Right) handler
+  where
+#if MIN_VERSION_base(4,9,0)
+    handler (ErrorCallWithLocation str _) = return $ Left str
+#else
+    handler (ErrorCall str) = return $ Left str
+#endif
 
 -------------------------------------------------------------------------------
 -- Helper data

cabal-install/Distribution/Client/BuildReports/Storage.hs

@@ -1,3 +1,5 @@
+-- TODO
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Distribution.Client.Reporting

cabal-install/Distribution/Client/CmdErrorMessages.hs

@@ -7,6 +7,9 @@ module Distribution.Client.CmdErrorMessages (
     module Distribution.Client.TargetSelector,
   ) where
 
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.TargetSelector
          ( ComponentKindFilter, componentKind, showTargetSelector )
@@ -22,8 +25,7 @@ import Distribution.Solver.Types.OptionalStanza
 import Distribution.Deprecated.Text
          ( display )
 
-import Data.Maybe (isNothing)
-import Data.List (sortBy, groupBy, nub)
+import qualified Data.List.NonEmpty as NE
 import Data.Function (on)
 
 
@@ -77,8 +79,8 @@ renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs
 -- >   | (pkgname, components) <- sortGroupOn packageName allcomponents ]
 --
 sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])]
-sortGroupOn key = map (\xs@(x:_) -> (key x, xs))
-                . groupBy ((==) `on` key)
+sortGroupOn key = map (\(x:|xs) -> (key x, x:xs))
+                . NE.groupBy ((==) `on` key)
                 . sortBy  (compare `on` key)
 
 

cabal-install/Distribution/Client/CmdInstall.hs

@@ -125,7 +125,7 @@ import Distribution.Pretty
 import Control.Exception
          ( catch )
 import Control.Monad
-         ( mapM, mapM_ )
+         ( mapM, forM_ )
 import qualified Data.ByteString.Lazy.Char8 as BS
 import Data.Either
          ( partitionEithers )
@@ -371,7 +371,7 @@ installAction ( configFlags, configExFlags, installFlags
               gatherTargets :: UnitId -> TargetSelector
               gatherTargets targetId = TargetPackageNamed pkgName targetFilter
                 where
-                  Just targetUnit = Map.lookup targetId planMap
+                  targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap
                   PackageIdentifier{..} = packageId targetUnit
 
               targets' = fmap gatherTargets targetIds
@@ -385,12 +385,11 @@ installAction ( configFlags, configExFlags, installFlags
 
             createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)
 
-            unless (Map.null targets) $
-              mapM_
-                (\(SpecificSourcePackage pkg) -> packageToSdist verbosity
+            unless (Map.null targets) $ forM_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of
+                SpecificSourcePackage pkg -> packageToSdist verbosity
                   (distProjectRootDirectory localDistDirLayout) TarGzArchive
                   (distSdistFile localDistDirLayout (packageId pkg)) pkg
-                ) (localPackages localBaseCtx)
+                NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName
 
             if null targets
               then return (hackagePkgs, hackageTargets)

cabal-install/Distribution/Client/CmdRepl.hs

@@ -250,13 +250,14 @@ replAction ( configFlags, configExFlags, installFlags
         -- help us resolve the targets, but that isn't ideal for performance,
         -- especially in the no-project case.
         withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do
+          -- targets should be non-empty map, but there's no NonEmptyMap yet.
           targets <- validatedTargets elaboratedPlan targetSelectors
 
           let
-            Just (unitId, _) = safeHead $ Map.toList targets
+            (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets
             originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId
             oci = OriginalComponentInfo unitId originalDeps
-            Just pkgId = packageId <$> InstallPlan.lookup elaboratedPlan unitId 
+            pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId 
             baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx
 
           return (Just oci, baseCtx')