Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
563d5017
Commit
563d5017
authored
Jul 10, 2018
by
Alexis Williams
Browse files
Fix new-install by 'PackageId'
parent
a8ce1182
Changes
1
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Client/CmdInstall.hs
View file @
563d5017
...
...
@@ -53,6 +53,8 @@ import Distribution.Simple.PackageIndex
(
InstalledPackageIndex
,
lookupPackageName
,
lookupUnitId
)
import
Distribution.Types.InstalledPackageInfo
(
InstalledPackageInfo
(
..
)
)
import
Distribution.Types.Version
(
nullVersion
)
import
Distribution.Types.VersionRange
(
thisVersion
)
import
Distribution.Solver.Types.PackageConstraint
...
...
@@ -78,9 +80,11 @@ import Distribution.Simple.Setup
,
trueArg
,
configureOptions
,
haddockOptions
,
flagToList
)
import
Distribution.Solver.Types.SourcePackage
(
SourcePackage
(
..
)
)
import
Distribution.ReadE
(
succeedReadE
)
import
Distribution.Simple.Command
(
CommandUI
(
..
),
ShowOrParseArgs
(
..
),
OptionField
(
..
)
,
option
,
usageAlternatives
)
,
option
,
usageAlternatives
,
reqArg
)
import
Distribution.Simple.Configure
(
configCompilerEx
)
import
Distribution.Simple.Compiler
...
...
@@ -102,11 +106,13 @@ import Distribution.Simple.Utils
,
ordNub
)
import
Distribution.Utils.Generic
(
writeFileAtomic
)
import
Distribution.Text
(
simpleParse
)
import
Control.Exception
(
catch
,
throwIO
)
import
Control.Monad
(
mapM_
)
(
mapM
,
mapM_
)
import
qualified
Data.ByteString.Lazy.Char8
as
BS
import
Data.Either
(
partitionEithers
)
...
...
@@ -240,8 +246,16 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstal
localBaseCtx
<-
establishProjectBaseContext
verbosity'
cliConfig
let
localDistDirLayout
=
distDirLayout
localBaseCtx
pkgDb
<-
projectConfigWithBuilderRepoContext
verbosity'
(
buildSettings
localBaseCtx
)
(
getSourcePackages
verbosity
)
let
(
targetStrings'
,
packageIds
)
=
partitionEithers
.
flip
fmap
targetStrings
$
\
str
->
case
simpleParse
str
of
Just
(
pkgId
::
PackageId
)
|
pkgVersion
pkgId
/=
nullVersion
->
Right
pkgId
_
->
Left
str
targetSelectors
<-
either
(
reportTargetSelectorProblems
verbosity
)
return
=<<
readTargetSelectors
(
localPackages
localBaseCtx
)
targetStrings
=<<
readTargetSelectors
(
localPackages
localBaseCtx
)
targetStrings
'
(
specs
,
selectors
)
<-
withInstallPlan
verbosity'
localBaseCtx
$
\
elaboratedPlan
->
do
-- Split into known targets and hackage packages.
...
...
@@ -321,17 +335,33 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstal
then
return
(
hackagePkgs
,
hackageTargets
)
else
return
(
local
++
hackagePkgs
,
targets'
++
hackageTargets
)
return
(
specs
,
selectors
,
projectConfig
localBaseCtx
)
let
packageSpecifiers
=
flip
fmap
packageIds
$
\
case
PackageIdentifier
{
..
}
|
pkgVersion
==
nullVersion
->
NamedPackage
pkgName
[]
|
otherwise
->
NamedPackage
pkgName
[
PackagePropertyVersion
(
thisVersion
pkgVersion
)]
packageTargets
=
flip
TargetPackageNamed
Nothing
.
pkgName
<$>
packageIds
return
(
specs
++
packageSpecifiers
,
selectors
++
packageTargets
,
projectConfig
localBaseCtx
)
withoutProject
=
do
let
parsePkg
pkgName
|
Just
(
pkg
::
PackageId
)
<-
simpleParse
pkgName
=
return
pkg
|
otherwise
=
die'
verbosity
(
"Invalid package ID: "
++
pkgName
)
packageIds
<-
mapM
parsePkg
targetStrings
let
packageNames
=
mkPackageName
<$>
targetStrings
packageSpecifiers
=
flip
NamedPackage
[]
<$>
packageNames
targetSelectors
=
flip
TargetPackageNamed
Nothing
<$>
packageNames
packageSpecifiers
=
flip
fmap
packageIds
$
\
case
PackageIdentifier
{
..
}
|
pkgVersion
==
nullVersion
->
NamedPackage
pkgName
[]
|
otherwise
->
NamedPackage
pkgName
[
PackagePropertyVersion
(
thisVersion
pkgVersion
)]
packageTargets
=
flip
TargetPackageNamed
Nothing
.
pkgName
<$>
packageIds
globalConfigFlag
=
projectConfigConfigFile
(
projectConfigShared
cliConfig
)
globalConfig
<-
runRebuild
""
$
readGlobalConfig
verbosity
globalConfigFlag
return
(
packageSpecifiers
,
targetSelector
s
,
globalConfig
<>
cliConfig
)
return
(
packageSpecifiers
,
packageTarget
s
,
globalConfig
<>
cliConfig
)
(
specs
,
selectors
,
config
)
<-
catch
withProject
$
\
case
...
...
@@ -376,7 +406,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstal
configCompilerEx
hcFlavor
hcPath
hcPkg
progDb
verbosity
let
envFile
=
flip
fromFlagOrDefault
ninstEnvironmentPath
$
envFile
=
flip
fromFlagOrDefault
(
ninstEnvironmentPath
newInstallFlags
)
$
home
</>
".ghc"
</>
ghcPlatformAndVersionString
platform
compilerVersion
</>
"environments"
</>
"default"
GhcImplInfo
{
supportsPkgEnvFiles
}
=
getImplInfo
compiler
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment