From 5286a7154290eceeb4a9ab4fe4df30b121288d1f Mon Sep 17 00:00:00 2001
From: Peter Becich <peter@simspace.com>
Date: Fri, 20 Aug 2021 22:49:20 -1000
Subject: [PATCH] more type annotations
---
.../src/Distribution/Client/Dependency.hs | 18 ++++++++++++++++++
cabal-install/src/Distribution/Client/Fetch.hs | 1 +
.../src/Distribution/Client/FetchUtils.hs | 2 ++
.../src/Distribution/Client/Freeze.hs | 2 ++
.../src/Distribution/Client/HttpUtils.hs | 1 +
.../src/Distribution/Client/ProjectBuilding.hs | 11 +++++++++++
.../src/Distribution/Client/ProjectPlanning.hs | 13 ++++++++++---
7 files changed, 45 insertions(+), 3 deletions(-)
diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs
index 14025d74d8..50c08076b6 100644
--- a/cabal-install/src/Distribution/Client/Dependency.hs
+++ b/cabal-install/src/Distribution/Client/Dependency.hs
@@ -13,6 +13,7 @@
-- Top level interface to dependency resolution.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency (
+ DepResolverParams,
-- * The main package dependency resolver
chooseSolver,
resolveDependencies,
@@ -464,6 +465,7 @@ removeBounds relKind relDeps params =
depResolverSourcePkgIndex = sourcePkgIndex'
}
where
+ sourcePkgIndex' :: PackageIndex.PackageIndex UnresolvedSourcePackage
sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params
relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
@@ -735,6 +737,7 @@ resolveDependencies platform comp pkgConfigDB solver params =
then params
else dontUpgradeNonUpgradeablePackages params
+ preferences :: PackageName -> PackagePreferences
preferences = interpretPackagesPreference targets defpref prefs
@@ -750,12 +753,14 @@ interpretPackagesPreference selected defaultPref prefs =
(installPref pkgname)
(stanzasPref pkgname)
where
+ versionPref :: PackageName -> [VersionRange]
versionPref pkgname =
fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)
versionPrefs = Map.fromListWith (++)
[(pkgname, [pref])
| PackageVersionPreference pkgname pref <- prefs]
+ installPref :: PackageName -> InstalledPreference
installPref pkgname =
fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
installPrefs = Map.fromList
@@ -770,6 +775,7 @@ interpretPackagesPreference selected defaultPref prefs =
if pkgname `Set.member` selected then PreferLatest
else PreferInstalled
+ stanzasPref :: PackageName -> [OptionalStanza]
stanzasPref pkgname =
fromMaybe [] (Map.lookup pkgname stanzasPrefs)
stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))
@@ -797,9 +803,12 @@ validateSolverResult platform comp indepGoals pkgs =
problems -> error (formatPkgProblems problems)
where
+ graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc)
graph = Graph.fromDistinctList pkgs
+ formatPkgProblems :: [PlanPackageProblem] -> String
formatPkgProblems = formatProblemMessage . map showPlanPackageProblem
+ formatPlanProblems :: [SolverInstallPlan.SolverPlanProblem] -> String
formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem
formatProblemMessage problems =
@@ -894,6 +903,7 @@ configuredPackageProblems platform cinfo
, not (packageSatisfiesDependency pkgid dep) ]
-- TODO: sanity tests on executable deps
where
+ thisPkgName :: PackageName
thisPkgName = packageName (srcpkgDescription pkg)
specifiedDeps1 :: ComponentDeps [PackageId]
@@ -902,10 +912,12 @@ configuredPackageProblems platform cinfo
specifiedDeps :: [PackageId]
specifiedDeps = CD.flatDeps specifiedDeps1
+ mergedFlags :: [MergeResult PD.FlagName PD.FlagName]
mergedFlags = mergeBy compare
(sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg)))
(sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO
+ packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool
packageSatisfiesDependency
(PackageIdentifier name version)
(Dependency name' versionRange _) = assert (name == name') $
@@ -991,7 +1003,9 @@ resolveWithoutDependencies (DepResolverParams targets constraints
where
-- Constraints
+ requiredVersions :: VersionRange
requiredVersions = packageConstraints pkgname
+ choices :: [UnresolvedSourcePackage]
choices = PackageIndex.lookupDependency sourcePkgIndex
pkgname
requiredVersions
@@ -1000,20 +1014,24 @@ resolveWithoutDependencies (DepResolverParams targets constraints
PackagePreferences preferredVersions preferInstalled _
= packagePreferences pkgname
+ bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
bestByPrefs = comparing $ \pkg ->
(installPref pkg, versionPref pkg, packageVersion pkg)
+ installPref :: UnresolvedSourcePackage -> Bool
installPref = case preferInstalled of
PreferLatest -> const False
PreferInstalled -> not . null
. InstalledPackageIndex.lookupSourcePackageId
installedPkgIndex
. packageId
+ versionPref :: Package a => a -> Int
versionPref pkg = length . filter (packageVersion pkg `withinRange`) $
preferredVersions
packageConstraints :: PackageName -> VersionRange
packageConstraints pkgname =
Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
+ packageVersionConstraintMap :: Map PackageName VersionRange
packageVersionConstraintMap =
let pcs = map unlabelPackageConstraint constraints
in Map.fromList [ (scopeToPackageName scope, range)
diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs
index 21d5318000..8e9496c8dc 100644
--- a/cabal-install/src/Distribution/Client/Fetch.hs
+++ b/cabal-install/src/Distribution/Client/Fetch.hs
@@ -147,6 +147,7 @@ planPackages verbosity comp platform fetchFlags
resolveWithoutDependencies resolverParams
where
+ resolverParams :: DepResolverParams
resolverParams =
setMaxBackjumps (if maxBackjumps < 0 then Nothing
diff --git a/cabal-install/src/Distribution/Client/FetchUtils.hs b/cabal-install/src/Distribution/Client/FetchUtils.hs
index b087867f5d..e632147d58 100644
--- a/cabal-install/src/Distribution/Client/FetchUtils.hs
+++ b/cabal-install/src/Distribution/Client/FetchUtils.hs
@@ -146,6 +146,7 @@ fetchPackage verbosity repoCtxt loc = case loc of
RemoteSourceRepoPackage _repo Nothing ->
die' verbosity "fetchPackage: source repos not supported"
where
+ downloadTarballPackage :: URI -> IO FilePath
downloadTarballPackage uri = do
transport <- repoContextGetTransport repoCtxt
transportCheckHttps verbosity transport uri
@@ -173,6 +174,7 @@ fetchRepoTarball verbosity' repoCtxt repo pkgid = do
-- whether we download or not is non-deterministic
verbosity = verboseUnmarkOutput verbosity'
+ downloadRepoPackage :: IO FilePath
downloadRepoPackage = case repo of
RepoLocalNoIndex{} -> return (packageFile repo pkgid)
diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs
index 1856ddad12..4b4ea1f31d 100644
--- a/cabal-install/src/Distribution/Client/Freeze.hs
+++ b/cabal-install/src/Distribution/Client/Freeze.hs
@@ -121,6 +121,7 @@ getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb
verbosity comp platform freezeFlags
installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
where
+ sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()
sanityCheck pkgSpecifiers = do
when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
die' verbosity $ "internal error: 'resolveUserTargets' returned "
@@ -154,6 +155,7 @@ planPackages verbosity comp platform freezeFlags
return $ pruneInstallPlan installPlan pkgSpecifiers
where
+ resolverParams :: DepResolverParams
resolverParams =
setMaxBackjumps (if maxBackjumps < 0 then Nothing
diff --git a/cabal-install/src/Distribution/Client/HttpUtils.hs b/cabal-install/src/Distribution/Client/HttpUtils.hs
index 6de14f3c66..e5708c87d0 100644
--- a/cabal-install/src/Distribution/Client/HttpUtils.hs
+++ b/cabal-install/src/Distribution/Client/HttpUtils.hs
@@ -143,6 +143,7 @@ downloadURI transport verbosity uri path = do
NeedsDownload hash -> makeDownload transport' hash Nothing
where
+ makeDownload :: HttpTransport -> Maybe BS8.ByteString -> Maybe String -> IO DownloadResult
makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do
result <- getHttp transport' verbosity uri etag tmpFile []
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
index 6e96c459fe..fd5a99ae92 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -230,6 +230,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
then dryRunLocalPkg pkg depsBuildStatus srcdir
else return (BuildStatusUnpack tarball)
where
+ srcdir :: FilePath
srcdir = distUnpackedSrcDirectory (packageId pkg)
dryRunLocalPkg :: ElaboratedConfiguredPackage
@@ -250,6 +251,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
Right buildResult ->
return (BuildStatusUpToDate buildResult)
where
+ packageFileMonitor :: PackageFileMonitor
packageFileMonitor =
newPackageFileMonitor shared distDirLayout
(elabDistDirParams shared pkg)
@@ -295,6 +297,7 @@ improveInstallPlanWithUpToDatePackages :: BuildStatusMap
improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
InstallPlan.installed canPackageBeImproved
where
+ canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool
canPackageBeImproved pkg =
case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
Just BuildStatusUpToDate {} -> True
@@ -376,6 +379,7 @@ packageFileMonitorKeyValues elab =
-- do not affect the configure step need to be nulled out. Those parts are
-- the specific targets that we're going to build.
--
+ elab_config :: ElaboratedConfiguredPackage
elab_config =
elab {
elabBuildTargets = [],
@@ -390,6 +394,7 @@ packageFileMonitorKeyValues elab =
-- more or less the opposite of the first part, as it's just the info about
-- what targets we're going to build.
--
+ buildComponents :: Set ComponentName
buildComponents = elabBuildTargetWholeComponents elab
-- | Do all the checks on whether a package has changed and thus needs either
@@ -464,6 +469,7 @@ checkPackageFileMonitorChanged PackageFileMonitor{..}
(docsResult, testsResult) = buildResult
where
(pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
+ changedToMaybe :: MonitorChanged a b -> Maybe b
changedToMaybe (MonitorChanged _) = Nothing
changedToMaybe (MonitorUnchanged x _) = Just x
@@ -681,6 +687,7 @@ rebuildTarget verbosity
where
unexpectedState = error "rebuildTarget: unexpected package status"
+ downloadPhase :: IO BuildResult
downloadPhase = do
downsrcloc <- annotateFailureNoLog DownloadFailed $
waitAsyncPackageDownload verbosity downloadMap pkg
@@ -888,6 +895,7 @@ unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
writeFileAtomic cabalFile pkgtxt
where
+ cabalFile :: FilePath
cabalFile = parentdir </> pkgsubdir
</> prettyShow pkgname <.> "cabal"
pkgsubdir = prettyShow pkgid
@@ -1081,12 +1089,14 @@ buildAndInstallUnpackedPackage verbosity
uid = installedUnitId rpkg
compid = compilerId compiler
+ dispname :: String
dispname = case elabPkgOrComp pkg of
ElabPackage _ -> prettyShow pkgid
++ " (all, legacy fallback)"
ElabComponent comp -> prettyShow pkgid
++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")"
+ noticeProgress :: ProgressPhase -> IO ()
noticeProgress phase = when isParallelBuild $
progressMessage verbosity phase dispname
@@ -1467,6 +1477,7 @@ withTempInstalledPackageInfoFile verbosity tempdir action =
"Couldn't parse the output of 'setup register --gen-pkg-config':"
++ show perror
+ readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf pkgConfDir pkgConfFile = do
pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)
(warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
index 45ea7c9ecc..4113f5f1fb 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -338,10 +338,12 @@ rebuildProjectConfig verbosity
ProjectConfigShared { projectConfigConfigFile } =
projectConfigShared cliConfig
+ fileMonitorProjectConfig ::
+ FileMonitor
+ (FilePath, FilePath)
+ (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage])
fileMonitorProjectConfig =
- newFileMonitor (distProjectCacheFile "config") :: FileMonitor
- (FilePath, FilePath)
- (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage])
+ newFileMonitor (distProjectCacheFile "config")
-- Read the cabal.project (or implicit config) and combine it with
-- arguments from the command line
@@ -964,6 +966,7 @@ planPackages verbosity comp platform solver SolverSettings{..}
--TODO: [nice to have] disable multiple instances restriction in
-- the solver, but then make sure we can cope with that in the
-- output.
+ resolverParams :: DepResolverParams
resolverParams =
setMaxBackjumps solverSettingMaxBackjumps
@@ -1074,6 +1077,7 @@ planPackages verbosity comp platform solver SolverSettings{..}
$ stdResolverParams
+ stdResolverParams :: DepResolverParams
stdResolverParams =
-- Note: we don't use the standardInstallPolicy here, since that uses
-- its own addDefaultSetupDependencies that is not appropriate for us.
@@ -1286,6 +1290,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
pkgConfigReplOptions = mempty
}
+ preexistingInstantiatedPkgs :: Map UnitId FullUnitId
preexistingInstantiatedPkgs =
Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan))
where
@@ -1297,6 +1302,8 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
(Map.fromList (IPI.instantiatedWith ipkg))))
f _ = Nothing
+ elaboratedInstallPlan ::
+ LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage)
elaboratedInstallPlan =
flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->
case planpkg of
--
GitLab