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/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