Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
06d1c93a
Commit
06d1c93a
authored
Jun 26, 2018
by
Alexis Williams
Browse files
Fix new-install outside of packages
parent
206a7fde
Changes
1
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Client/CmdInstall.hs
View file @
06d1c93a
...
...
@@ -31,7 +31,7 @@ import Distribution.Client.ProjectPlanning.Types
(
pkgConfigCompiler
)
import
qualified
Distribution.Client.InstallPlan
as
InstallPlan
import
Distribution.Package
(
Package
(
..
)
)
(
Package
(
..
)
,
mkPackageName
)
import
Distribution.Types.PackageId
(
PackageIdentifier
(
..
)
)
import
Distribution.Client.ProjectConfig.Types
...
...
@@ -45,7 +45,9 @@ import Distribution.Client.IndexUtils
(
getSourcePackages
)
import
Distribution.Client.ProjectConfig
(
readGlobalConfig
,
projectConfigWithBuilderRepoContext
,
resolveBuildTimeSettings
)
,
resolveBuildTimeSettings
,
BadPackageLocations
(
..
),
BadPackageLocation
(
..
)
,
ProjectConfigProvenance
(
..
)
)
import
Distribution.Client.DistDirLayout
(
defaultDistDirLayout
,
DistDirLayout
(
..
),
mkCabalDirLayout
,
ProjectRoot
(
ProjectRootImplicit
)
...
...
@@ -72,8 +74,10 @@ import Distribution.Simple.Utils
(
wrapText
,
die'
,
notice
,
withTempDirectory
,
createDirectoryIfMissingVerbose
)
import
Control.Exception
(
catch
,
throwIO
)
import
Data.Either
(
partitionEithers
)
import
qualified
Data.Map
as
Map
import
qualified
Data.Set
as
Set
import
System.Directory
(
getTemporaryDirectory
,
makeAbsolute
)
import
System.FilePath
(
(
</>
)
)
...
...
@@ -142,93 +146,114 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
die'
verbosity
$
"--enable-benchmarks was specified, but benchmarks can't "
++
"be enabled in a remote package"
let
verbosity'
=
lessVerbose
verbosity
-- First, we need to learn about what's available to be installed.
localBaseCtx
<-
establishProjectBaseContext
verbosity'
cliConfig
let
localDistDirLayout
=
distDirLayout
localBaseCtx
pkgDb
<-
projectConfigWithBuilderRepoContext
verbosity'
(
buildSettings
localBaseCtx
)
(
getSourcePackages
verbosity
)
targetSelectors
<-
either
(
reportTargetSelectorProblems
verbosity
)
return
=<<
readTargetSelectors
(
localPackages
localBaseCtx
)
targetStrings
(
specs
,
selectors
)
<-
withInstallPlan
verbosity'
localBaseCtx
$
\
elaboratedPlan
->
do
-- Split into known targets and hackage packages.
(
targets
,
hackageNames
)
<-
case
resolveTargets
selectPackageTargets
selectComponentTarget
TargetProblemCommon
elaboratedPlan
(
Just
pkgDb
)
targetSelectors
of
Right
targets
->
do
-- Everything is a local dependency.
return
(
targets
,
[]
)
Left
errs
->
do
-- Not everything is local.
let
(
errs'
,
hackageNames
)
=
partitionEithers
.
flip
fmap
errs
$
\
case
TargetProblemCommon
(
TargetAvailableInIndex
name
)
->
Right
name
err
->
Left
err
when
(
not
.
null
$
errs'
)
$
reportTargetProblems
verbosity
errs'
let
targetSelectors'
=
flip
filter
targetSelectors
$
\
case
TargetComponentUnknown
name
_
_
|
name
`
elem
`
hackageNames
->
False
TargetPackageNamed
name
_
|
name
`
elem
`
hackageNames
->
False
_
->
True
-- This can't fail, because all of the errors are removed (or we've given up).
targets
<-
either
(
reportTargetProblems
verbosity
)
return
$
resolveTargets
let
withProject
=
do
let
verbosity'
=
lessVerbose
verbosity
-- First, we need to learn about what's available to be installed.
localBaseCtx
<-
establishProjectBaseContext
verbosity'
cliConfig
let
localDistDirLayout
=
distDirLayout
localBaseCtx
pkgDb
<-
projectConfigWithBuilderRepoContext
verbosity'
(
buildSettings
localBaseCtx
)
(
getSourcePackages
verbosity
)
targetSelectors
<-
either
(
reportTargetSelectorProblems
verbosity
)
return
=<<
readTargetSelectors
(
localPackages
localBaseCtx
)
targetStrings
let
sdistFlags
=
defaultSdistFlags
{
sdistVerbosity
=
Flag
verbosity'
,
sdistDistDir
=
projectConfigDistDir
(
projectConfigShared
cliConfig
)
,
sdistProjectFile
=
projectConfigProjectFile
(
projectConfigShared
cliConfig
)
}
sdistAction
sdistFlags
[
"all"
]
globalFlags
withInstallPlan
verbosity'
localBaseCtx
$
\
elaboratedPlan
->
do
-- Split into known targets and hackage packages.
(
targets
,
hackageNames
)
<-
case
resolveTargets
selectPackageTargets
selectComponentTarget
TargetProblemCommon
elaboratedPlan
Nothing
targetSelectors'
(
Just
pkgDb
)
targetSelectors
of
Right
targets
->
do
-- Everything is a local dependency.
return
(
targets
,
[]
)
Left
errs
->
do
-- Not everything is local.
let
(
errs'
,
hackageNames
)
=
partitionEithers
.
flip
fmap
errs
$
\
case
TargetProblemCommon
(
TargetAvailableInIndex
name
)
->
Right
name
err
->
Left
err
when
(
not
.
null
$
errs'
)
$
reportTargetProblems
verbosity
errs'
return
(
targets
,
hackageNames
)
let
targetSelectors'
=
flip
filter
targetSelectors
$
\
case
TargetComponentUnknown
name
_
_
|
name
`
elem
`
hackageNames
->
False
TargetPackageNamed
name
_
|
name
`
elem
`
hackageNames
->
False
_
->
True
-- This can't fail, because all of the errors are removed (or we've given up).
targets
<-
either
(
reportTargetProblems
verbosity
)
return
$
resolveTargets
selectPackageTargets
selectComponentTarget
TargetProblemCommon
elaboratedPlan
Nothing
targetSelectors'
return
(
targets
,
hackageNames
)
let
planMap
=
InstallPlan
.
toMap
elaboratedPlan
targetIds
=
Map
.
keys
targets
let
planMap
=
InstallPlan
.
toMap
elaboratedPlan
targetIds
=
Map
.
keys
targets
sdistize
(
SpecificSourcePackage
spkg
@
SourcePackage
{
..
})
=
SpecificSourcePackage
spkg'
where
sdistPath
=
distSdistFile
localDistDirLayout
packageInfoId
TargzFormat
spkg'
=
spkg
{
packageSource
=
LocalTarballPackage
sdistPath
}
sdistize
named
=
named
local
=
sdistize
<$>
localPackages
localBaseCtx
sdistize
(
SpecificSourcePackage
spkg
@
SourcePackage
{
..
})
=
SpecificSourcePackage
spkg'
where
sdistPath
=
distSdistFile
localDistDirLayout
packageInfoId
TargzFormat
spkg'
=
spkg
{
packageSource
=
LocalTarballPackage
sdistPath
}
sdistize
named
=
named
gatherTargets
::
UnitId
->
TargetSelector
gatherTargets
targetId
=
TargetPackageNamed
pkgName
Nothing
where
Just
targetUnit
=
Map
.
lookup
targetId
planMap
PackageIdentifier
{
..
}
=
packageId
targetUnit
targets'
=
fmap
gatherTargets
targetIds
local
=
sdistize
<$>
localPackages
localBaseCtx
gatherTargets
::
UnitId
->
TargetSelector
gatherTargets
targetId
=
TargetPackageNamed
pkgName
Nothing
where
Just
targetUnit
=
Map
.
lookup
targetId
planMap
PackageIdentifier
{
..
}
=
packageId
targetUnit
targets'
=
fmap
gatherTargets
targetIds
hackagePkgs
::
[
PackageSpecifier
UnresolvedSourcePackage
]
hackagePkgs
=
flip
NamedPackage
[]
<$>
hackageNames
hackageTargets
::
[
TargetSelector
]
hackageTargets
=
flip
TargetPackageNamed
Nothing
<$>
hackageNames
if
null
targets
then
return
(
hackagePkgs
,
hackageTargets
)
else
return
(
local
++
hackagePkgs
,
targets'
++
hackageTargets
)
withoutProject
=
do
let
packageNames
=
mkPackageName
<$>
targetStrings
packageSpecifiers
=
flip
NamedPackage
[]
<$>
packageNames
targetSelectors
=
flip
TargetPackageNamed
Nothing
<$>
packageNames
hackagePkgs
::
[
PackageSpecifier
UnresolvedSourcePackage
]
hackagePkgs
=
flip
NamedPackage
[]
<$>
hackageNames
hackageTargets
::
[
TargetSelector
]
hackageTargets
=
flip
TargetPackageNamed
Nothing
<$>
hackageNames
if
null
targets
then
return
(
hackagePkgs
,
hackageTargets
)
else
return
(
local
++
hackagePkgs
,
targets'
++
hackageTargets
)
let
sdistFlags
=
defaultSdistFlags
{
sdistVerbosity
=
Flag
verbosity'
,
sdistDistDir
=
projectConfigDistDir
(
projectConfigShared
cliConfig
)
,
sdistProjectFile
=
projectConfigProjectFile
(
projectConfigShared
cliConfig
)
}
sdistAction
sdistFlags
[
"all"
]
globalFlags
return
(
packageSpecifiers
,
targetSelectors
)
(
specs
,
selectors
)
<-
catch
withProject
$
\
case
(
BadPackageLocations
prov
locs
)
|
prov
==
Set
.
singleton
Implicit
,
let
isGlobErr
(
BadLocGlobEmptyMatch
_
)
=
True
isGlobErr
_
=
False
,
any
isGlobErr
locs
->
withoutProject
err
->
throwIO
err
-- Second, we need to use a fake project to let Cabal build the
-- installables correctly. For that, we need a place to put a
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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