Commit 6a5cd879 authored by Oleg Grenrus's avatar Oleg Grenrus

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.
parent 009c42d3
......@@ -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
......
......@@ -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:
......
......@@ -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
......@@ -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)
......
......@@ -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.
......
......@@ -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
......
......@@ -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"
......
......@@ -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
......@@ -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
......
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
-- TODO
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Reporting
......
......@@ -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)
......
......@@ -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)
......
......@@ -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')
......
......@@ -12,6 +12,8 @@ import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry,
import Control.Exception (mask_, onException)
import Control.Monad (join, unless)
import Data.Typeable (Typeable)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
-- | 'QSem' is a quantity semaphore in which the resource is aqcuired
-- and released in units of one. It provides guaranteed FIFO ordering
......@@ -97,8 +99,8 @@ signalQSem s@(QSem q b1 b2) =
checkwake2 [] = do
writeTVar q 1
return (return ())
checkwake2 ys = do
let (z:zs) = reverse ys
checkwake2 (y:ys) = do
let (z:|zs) = NE.reverse (y:|ys)
writeTVar b1 zs
writeTVar b2 []
return (wake s z)
......@@ -89,7 +89,7 @@ sandboxEnvironment verbosity sandboxDir comp platform programDb iEnv =
Windows -> "PATH"
_ -> "LD_LIBRARY_PATH"
env getGlobalPackageDB hcProgram packagePathEnvVar = do
let Just program = lookupProgram hcProgram programDb
let program = fromMaybe (error "failed to find hcProgram") $ lookupProgram hcProgram programDb
gDb <- getGlobalPackageDB verbosity program
sandboxConfigFilePath <- getSandboxConfigFilePath mempty
let sandboxPackagePath = sandboxPackageDBPath sandboxDir comp platform
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving,
NamedFieldPuns, BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
......@@ -1097,11 +1098,16 @@ checkDirectoryModificationTime dir mtime =
then return Nothing
else return (Just mtime')
-- | Run an IO computation, returning @e@ if there is an 'error'
-- | Run an IO computation, returning the first argument @e@ if there is an 'error'
-- call. ('ErrorCall')
handleErrorCall :: a -> IO a -> IO a
handleErrorCall e =
handle (\(ErrorCall _) -> return e)
handleErrorCall e = handle handler where
#if MIN_VERSION_base(4,9,0)
handler (ErrorCallWithLocation _ _) = return e
#else
handler (ErrorCall _) = return e
#endif
-- | Run an IO computation, returning @e@ if there is any 'IOException'.
--
......
......@@ -35,6 +35,7 @@ import Distribution.Simple.Utils
( notice, die', info, writeFileAtomic )
import Distribution.Verbosity
( Verbosity )
import Distribution.Pretty (prettyShow)
import Distribution.Deprecated.Text (display)
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Program
......@@ -273,7 +274,7 @@ clonePackagesFromSourceRepo verbosity destDirPrefix
throwIO (ClonePackageFailedWithExitCode
pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode)
| (pkgid, repo, vcs, destDir) <- pkgrepos'
, let Just vcs' = Map.lookup (vcsRepoType vcs) vcss
, let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss
]
where
......
......@@ -282,7 +282,7 @@ configureTransport verbosity extraPath (Just name) =
Just prog -> snd <$> requireProgram verbosity prog baseProgDb
-- ^^ if it fails, it'll fail here
let Just transport = mkTrans progdb
let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb
return transport { transportManuallySelected = True }
Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name
......@@ -645,9 +645,11 @@ powershellTransport prog =
HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value
HdrReferer -> "Referer = " ++ escape value
HdrTransferEncoding -> "TransferEncoding = " ++ escape value
HdrRange -> let (start, _:end) =
HdrRange -> let (start, end) =
if "bytes=" `isPrefixOf` value
then break (== '-') value'
then case break (== '-') value' of
(start', '-':end') -> (start', end')
_ -> error $ "Could not decode range: " ++ value
else error $ "Could not decode range: " ++ value
value' = drop 6 value
in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
......
......@@ -951,7 +951,9 @@ createMainHs flags =
_ -> writeMainHs flags mainFile
else return ()
where
Flag mainFile = mainIs flags
mainFile = case mainIs flags of
Flag x -> x
NoFlag -> error "createMainHs: no mainIs"
--- | Write a main file if it doesn't already exist.
writeMainHs :: InitFlags -> FilePath -> IO ()
......
......@@ -286,7 +286,7 @@ foldMInstallPlanDepOrder visit =
-- we go in the right order so the results map has entries for all deps
let depresults :: [b]
depresults =
map (\ipkgid -> let Just result = Map.lookup ipkgid results
map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results
in result)
(InstallPlan.depends pkg)
result <- visit pkg depresults
......@@ -596,7 +596,7 @@ rebuildTargets verbosity
handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $
let uid = installedUnitId pkg
Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in
pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in
rebuildTarget
verbosity
......@@ -756,7 +756,7 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
| InstallPlan.Configured elab
<- InstallPlan.reverseTopologicalOrder installPlan
, let uid = installedUnitId elab
Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus
pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus
, BuildStatusDownload <- [pkgBuildStatus]
]
......
......@@ -100,7 +100,7 @@ import Distribution.PackageDescription.Parsec
( parseGenericPackageDescription )
import Distribution.Fields
( runParseResult, PError, PWarning, showPWarning)
import Distribution.Pretty ()
import Distribution.Pretty (prettyShow)
import Distribution.Types.SourceRepo
( RepoType(..) )
import Distribution.Client.SourceRepo
......@@ -1152,7 +1152,7 @@ syncAndReadSourcePackagesRemoteRepos verbosity
--TODO: pass progPathExtra on to 'configureVCS'
let _progPathExtra = fromNubList projectConfigProgPathExtra
getConfiguredVCS <- delayInitSharedResources $ \repoType ->
let Just vcs = Map.lookup repoType knownVCSs in
let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in
configureVCS verbosity {-progPathExtra-} vcs
concat <$> sequence
......
......@@ -166,6 +166,7 @@ import qualified Data.Traversable as T
import Control.Monad.State as State
import Control.Exception
import Data.List (groupBy)
import qualified Data.List.NonEmpty as NE
import Data.Either
import Data.Function
import System.FilePath
......@@ -877,8 +878,8 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
return (pkgid, hashFromTUF hash)
| pkgid <- pkgids ]
| (repo, pkgids) <-
map (\grp@((_,repo):_) -> (repo, map fst grp))
. groupBy ((==) `on` (remoteRepoName . repoRemote . snd))
map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp)))
. NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd))
. sortBy (compare `on` (remoteRepoName . repoRemote . snd))
$ repoTarballPkgsWithMetadata
]
......@@ -1714,12 +1715,12 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
elabIsCanonical = True
elabPkgSourceId = pkgid
elabPkgDescription = let Right (desc, _) =
PD.finalizePD
elabPkgDescription = case PD.finalizePD
flags elabEnabledSpec (const True)
platform (compilerInfo compiler)
[] gdesc
in desc
[] gdesc of
Right (desc, _) -> desc
Left _ -> error "Failed to finalizePD in elaborateSolverToCommon"
elabFlagAssignment = flags
elabFlagDefaults = PD.mkFlagAssignment
[ (Cabal.flagName flag, Cabal.flagDefault flag)
......
{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor,
RecordWildCards, NamedFieldPuns #-}
-- TODO
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.TargetSelector
......@@ -78,6 +80,7 @@ import Data.Function
( on )
import Data.List
( stripPrefix, partition, groupBy )
import qualified Data.List.NonEmpty as NE
import Data.Ord