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
717cf359
Commit
717cf359
authored
Nov 26, 2014
by
Christiaan Baaij
Browse files
Correctly calculate relative paths for relocatable packages
parent
a1328251
Changes
6
Hide whitespace changes
Inline
Side-by-side
Cabal/Distribution/Simple/GHC.hs
View file @
717cf359
...
...
@@ -62,14 +62,13 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import
qualified
Distribution.Simple.PackageIndex
as
PackageIndex
import
Distribution.Simple.LocalBuildInfo
(
LocalBuildInfo
(
..
),
ComponentLocalBuildInfo
(
..
)
,
LibraryName
(
..
),
absoluteInstallDirs
,
prefixRelativeInstallDirs
)
,
LibraryName
(
..
),
absoluteInstallDirs
)
import
qualified
Distribution.Simple.Hpc
as
Hpc
import
Distribution.Simple.InstallDirs
hiding
(
absoluteInstallDirs
,
prefixRelativeInstallDirs
)
import
Distribution.Simple.InstallDirs
hiding
(
absoluteInstallDirs
)
import
Distribution.Simple.BuildPaths
import
Distribution.Simple.Utils
import
Distribution.Package
(
PackageName
(
..
),
Package
(
..
),
InstalledPackageId
,
PackageId
)
(
PackageName
(
..
),
InstalledPackageId
,
PackageId
)
import
qualified
Distribution.ModuleName
as
ModuleName
import
Distribution.Simple.Program
(
Program
(
..
),
ConfiguredProgram
(
..
),
ProgramConfiguration
...
...
@@ -94,7 +93,7 @@ import qualified Distribution.Simple.Setup as Cabal
import
Distribution.Simple.Compiler
(
CompilerFlavor
(
..
),
CompilerId
(
..
),
Compiler
(
..
),
compilerVersion
,
OptimisationLevel
(
..
),
PackageDB
(
..
),
PackageDBStack
,
AbiTag
(
..
)
,
Flag
,
packageKeySupported
)
,
Flag
)
import
Distribution.Version
(
Version
(
..
),
anyVersion
,
orLaterVersion
)
import
Distribution.System
...
...
@@ -111,13 +110,13 @@ import Control.Monad ( unless, when )
import
Data.Char
(
isDigit
,
isSpace
)
import
Data.List
import
qualified
Data.Map
as
M
(
Map
,
fromList
,
lookup
)
import
Data.Maybe
(
catMaybes
,
fromJust
,
fromMaybe
,
maybeToList
)
import
Data.Maybe
(
catMaybes
,
fromMaybe
,
maybeToList
)
import
Data.Monoid
(
Monoid
(
..
)
)
import
System.Directory
(
getDirectoryContents
,
doesFileExist
,
getTemporaryDirectory
)
import
System.FilePath
(
(
</>
),
(
<.>
),
takeExtension
,
takeDirectory
,
replaceExtension
,
splitExtension
,
splitDirectories
,
joinPath
)
splitExtension
)
import
System.IO
(
hClose
,
hPutStrLn
)
import
System.Environment
(
getEnv
)
import
Distribution.Compat.Exception
(
catchExit
,
catchIO
)
...
...
@@ -912,7 +911,7 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do
ghcOptLinkLibPath
=
toNubListR
$
extraLibDirs
libBi
,
ghcOptRPaths
=
if
(
hostOS
==
OSX
&&
relocatable
lbi
)
then
toRPaths
False
pkg_descr
lbi
clbi
then
toRPaths
False
pkg_descr
lbi
else
mempty
}
...
...
@@ -936,41 +935,21 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do
toRPaths
::
Bool
-- ^ Building exe?
->
PackageDescription
->
LocalBuildInfo
->
ComponentLocalBuildInfo
->
NubListR
FilePath
toRPaths
buildE
_pkg_descr
lbi
clbi
=
toNubListR
$
map
(
lib
Pref
</>
)
depsK
toRPaths
buildE
_pkg_descr
lbi
=
toNubListR
(
map
(
host
Pref
</>
)
refDirs
)
where
(
Platform
_hostArch
hostOS
)
=
hostPlatform
lbi
ipkgs
=
installedPkgs
lbi
deps
=
map
fst
(
componentPackageDeps
clbi
)
depsP
=
catMaybes
(
map
(
PackageIndex
.
lookupInstalledPackageId
ipkgs
)
deps
)
depsK
=
if
packageKeySupported
(
compiler
lbi
)
then
map
(
display
.
InstalledPackageInfo
.
packageKey
)
depsP
else
map
(
display
.
snd
)
(
componentPackageDeps
clbi
)
installDirs
=
fmap
fromJust
(
prefixRelativeInstallDirs
(
packageId
_pkg_descr
)
lbi
)
relPref
=
shortRelativePath
(
bindir
installDirs
)
(
takeDirectory
(
libdir
installDirs
))
libPref
=
case
hostOS
of
OSX
->
if
buildE
then
"@loader_path"
</>
relPref
else
"@origin"
</>
".."
_
->
if
buildE
then
"$ORIGIN"
</>
relPref
else
"$ORIGIN"
</>
".."
dropCommonPrefix
::
Eq
a
=>
[
a
]
->
[
a
]
->
([
a
],[
a
])
dropCommonPrefix
(
x
:
xs
)
(
y
:
ys
)
|
x
==
y
=
dropCommonPrefix
xs
ys
dropCommonPrefix
xs
ys
=
(
xs
,
ys
)
shortRelativePath
::
FilePath
->
FilePath
->
FilePath
shortRelativePath
from
to
=
case
dropCommonPrefix
(
splitDirectories
from
)
(
splitDirectories
to
)
of
(
stuff
,
path
)
->
joinPath
(
map
(
const
".."
)
stuff
++
path
)
installDirs
=
absoluteInstallDirs
_pkg_descr
lbi
NoCopyDest
relDir
|
buildE
=
bindir
installDirs
|
otherwise
=
libdir
installDirs
ipkgs
=
PackageIndex
.
allPackages
(
installedPkgs
lbi
)
allDepLibDirs
=
concatMap
InstalledPackageInfo
.
libraryDirs
ipkgs
refDirs
=
map
(
shortRelativePath
relDir
)
allDepLibDirs
(
Platform
_
hostOS
)
=
hostPlatform
lbi
hostPref
=
case
hostOS
of
OSX
->
"@loader_path"
_
->
"$ORIGIN"
-- | Start a REPL without loading any source files.
startInterpreter
::
Verbosity
->
ProgramConfiguration
->
Compiler
...
...
@@ -1073,7 +1052,7 @@ buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi
[
exeDir
</>
x
|
x
<-
cObjs
],
ghcOptRPaths
=
if
(
hostOS
==
OSX
&&
relocatable
lbi
)
then
toRPaths
True
_pkg_descr
lbi
clbi
then
toRPaths
True
_pkg_descr
lbi
else
mempty
}
replOpts
=
baseOpts
{
...
...
Cabal/Distribution/Simple/InstallDirs.hs
View file @
717cf359
...
...
@@ -28,7 +28,6 @@ module Distribution.Simple.InstallDirs (
CopyDest
(
..
),
prefixRelativeInstallDirs
,
substituteInstallDirTemplates
,
substituteInstallDirTemplatesNP
,
PathTemplate
,
PathTemplateVariable
(
..
),
...
...
@@ -281,42 +280,6 @@ substituteInstallDirTemplates env dirs = dirs'
prefixBinLibVars
=
[
prefixVar
,
bindirVar
,
libdirVar
,
libsubdirVar
]
prefixBinLibDataVars
=
prefixBinLibVars
++
[
datadirVar
,
datasubdirVar
]
-- | Like 'substituteInstallDirTemplates', but does not allow substitution of
-- the 'prefix' variable
substituteInstallDirTemplatesNP
::
PathTemplateEnv
->
InstallDirTemplates
->
InstallDirTemplates
substituteInstallDirTemplatesNP
env
dirs
=
dirs'
where
dirs'
=
InstallDirs
{
-- So this specifies exactly which vars are allowed in each template
prefix
=
subst
prefix
[]
,
bindir
=
subst
bindir
[]
,
libdir
=
subst
libdir
[
bindirVar
],
libsubdir
=
subst
libsubdir
[]
,
dynlibdir
=
subst
dynlibdir
[
bindirVar
,
libdirVar
],
libexecdir
=
subst
libexecdir
prefixBinLibVars
,
includedir
=
subst
includedir
prefixBinLibVars
,
datadir
=
subst
datadir
prefixBinLibVars
,
datasubdir
=
subst
datasubdir
[]
,
docdir
=
subst
docdir
prefixBinLibDataVars
,
mandir
=
subst
mandir
(
prefixBinLibDataVars
++
[
docdirVar
]),
htmldir
=
subst
htmldir
(
prefixBinLibDataVars
++
[
docdirVar
]),
haddockdir
=
subst
haddockdir
(
prefixBinLibDataVars
++
[
docdirVar
,
htmldirVar
]),
sysconfdir
=
subst
sysconfdir
prefixBinLibVars
}
subst
dir
env'
=
substPathTemplate
(
env'
++
env
)
(
dir
dirs
)
bindirVar
=
(
BindirVar
,
bindir
dirs'
)
libdirVar
=
(
LibdirVar
,
libdir
dirs'
)
libsubdirVar
=
(
LibsubdirVar
,
libsubdir
dirs'
)
datadirVar
=
(
DatadirVar
,
datadir
dirs'
)
datasubdirVar
=
(
DatasubdirVar
,
datasubdir
dirs'
)
docdirVar
=
(
DocdirVar
,
docdir
dirs'
)
htmldirVar
=
(
HtmldirVar
,
htmldir
dirs'
)
prefixBinLibVars
=
[
bindirVar
,
libdirVar
,
libsubdirVar
]
prefixBinLibDataVars
=
prefixBinLibVars
++
[
datadirVar
,
datasubdirVar
]
-- | Convert from abstract install directories to actual absolute ones by
-- substituting for all the variables in the abstract paths, to get real
-- absolute path.
...
...
Cabal/Distribution/Simple/Program/HcPkg.hs
View file @
717cf359
...
...
@@ -19,6 +19,7 @@ module Distribution.Simple.Program.HcPkg (
hide
,
dump
,
list
,
pkgRoot
,
-- * Program invocations
initInvocation
,
...
...
@@ -271,6 +272,48 @@ list verbosity hcPkg packagedb = do
where
parsePackageIds
=
sequence
.
map
simpleParse
.
words
-- | Call @hc-pkg@ to get the location of PackageDB.
pkgRoot
::
Verbosity
->
ConfiguredProgram
->
PackageDB
->
IO
(
Maybe
FilePath
)
pkgRoot
_
_
(
SpecificPackageDB
fp
)
=
return
(
Just
fp
)
pkgRoot
verbosity
hcPkg
packagedb
=
do
output
<-
getProgramInvocationOutput
verbosity
(
dumpInvocation
hcPkg
verbosity
packagedb
)
`
catchExit
`
\
_
->
die
$
programId
hcPkg
++
" pkgRoot failed"
case
parsePkgRoot
output
of
Left
ok
->
return
ok
_
->
die
$
"failed to parse output of '"
++
programId
hcPkg
++
" pkgRoot'"
where
parsePkgRoot
str
=
case
splitPkgs
str
of
[]
->
Left
Nothing
(
pkg
:
_
)
->
case
parsePkgRoot'
pkg
of
ParseOk
_
pkgroot
->
Left
pkgroot
ParseFailed
msg
->
Right
msg
parsePkgRoot'
=
parseFieldsFlat
[
pkgrootField
]
Nothing
where
pkgrootField
=
simpleField
"pkgroot"
showFilePath
parseFilePathQ
(
fromMaybe
""
)
(
\
x
_
->
Just
x
)
--TODO: this could be a lot faster. We're doing normaliseLineEndings twice
-- and converting back and forth with lines/unlines.
splitPkgs
::
String
->
[
String
]
splitPkgs
=
checkEmpty
.
map
unlines
.
splitWith
(
"---"
==
)
.
lines
where
-- Handle the case of there being no packages at all.
checkEmpty
[
s
]
|
all
isSpace
s
=
[]
checkEmpty
ss
=
ss
splitWith
::
(
a
->
Bool
)
->
[
a
]
->
[[
a
]]
splitWith
p
xs
=
ys
:
case
zs
of
[]
->
[]
_
:
ws
->
splitWith
p
ws
where
(
ys
,
zs
)
=
break
p
xs
--------------------------
-- The program invocations
...
...
Cabal/Distribution/Simple/Register.hs
View file @
717cf359
...
...
@@ -40,7 +40,7 @@ import Distribution.Simple.LocalBuildInfo
(
LocalBuildInfo
(
..
),
ComponentLocalBuildInfo
(
..
)
,
ComponentName
(
..
),
getComponentLocalBuildInfo
,
LibraryName
(
..
)
,
InstallDirs
(
..
),
absoluteInstallDirs
,
prefixRelativeInstallDirs
)
,
InstallDirs
(
..
),
absoluteInstallDirs
)
import
Distribution.Simple.BuildPaths
(
haddockName
)
import
qualified
Distribution.Simple.GHC
as
GHC
import
qualified
Distribution.Simple.LHC
as
LHC
...
...
@@ -48,7 +48,8 @@ import qualified Distribution.Simple.UHC as UHC
import
qualified
Distribution.Simple.HaskellSuite
as
HaskellSuite
import
Distribution.Simple.Compiler
(
compilerVersion
,
Compiler
,
CompilerFlavor
(
..
),
compilerFlavor
,
PackageDBStack
,
registrationPackageDB
)
,
PackageDB
,
PackageDBStack
,
absolutePackageDBPaths
,
registrationPackageDB
)
import
Distribution.Simple.Program
(
ProgramConfiguration
,
ConfiguredProgram
,
runProgramInvocation
,
requireProgram
,
lookupProgram
...
...
@@ -69,7 +70,7 @@ import Distribution.InstalledPackageInfo
import
qualified
Distribution.InstalledPackageInfo
as
IPI
import
Distribution.Simple.Utils
(
writeUTF8File
,
writeFileAtomic
,
setFileExecutable
,
die
,
notice
,
setupMessage
)
,
die
,
notice
,
setupMessage
,
shortRelativePath
)
import
Distribution.System
(
OS
(
..
),
buildOS
)
import
Distribution.Text
...
...
@@ -84,7 +85,7 @@ import System.Directory
import
Control.Monad
(
when
)
import
Data.Maybe
(
isJust
,
fromJust
,
fromMaybe
,
maybeToList
)
(
isJust
,
fromMaybe
,
maybeToList
)
import
Data.List
(
partition
,
nub
)
import
qualified
Data.ByteString.Lazy.Char8
as
BS.Char8
...
...
@@ -99,8 +100,10 @@ register pkg@PackageDescription { library = Just lib } lbi regFlags
=
do
let
clbi
=
getComponentLocalBuildInfo
lbi
CLibName
absPackageDBs
<-
absolutePackageDBPaths
packageDbs
installedPkgInfo
<-
generateRegistrationInfo
verbosity
pkg
lib
lbi
clbi
inplace
reloc
distPref
(
registrationPackageDB
absPackageDBs
)
when
(
fromFlag
(
regPrintId
regFlags
))
$
do
putStrLn
(
display
(
IPI
.
installedPackageId
installedPkgInfo
))
...
...
@@ -156,8 +159,9 @@ generateRegistrationInfo :: Verbosity
->
Bool
->
Bool
->
FilePath
->
PackageDB
->
IO
InstalledPackageInfo
generateRegistrationInfo
verbosity
pkg
lib
lbi
clbi
inplace
reloc
distPref
=
do
generateRegistrationInfo
verbosity
pkg
lib
lbi
clbi
inplace
reloc
distPref
packageDb
=
do
--TODO: eliminate pwd!
pwd
<-
getCurrentDirectory
...
...
@@ -172,16 +176,45 @@ generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref = do
_other
->
do
return
(
InstalledPackageId
(
display
(
packageId
pkg
)))
let
installedPkgInfo
|
inplace
=
inplaceInstalledPackageInfo
pwd
distPref
pkg
ipid
lib
lbi
clbi
|
reloc
=
relocatableInstalledPackageInfo
pkg
ipid
lib
lbi
clbi
|
otherwise
=
absoluteInstalledPackageInfo
pkg
ipid
lib
lbi
clbi
-- let installedPkgInfo
-- | inplace = inplaceInstalledPackageInfo pwd distPref
-- pkg ipid lib lbi clbi
-- | reloc = relocatableInstalledPackageInfo
-- pkg ipid lib lbi clbi undefined
-- | otherwise = absoluteInstalledPackageInfo
-- pkg ipid lib lbi clbi
installedPkgInfo
<-
if
inplace
then
return
(
inplaceInstalledPackageInfo
pwd
distPref
pkg
ipid
lib
lbi
clbi
)
else
if
reloc
then
relocRegistrationInfo
verbosity
pkg
lib
lbi
clbi
ipid
packageDb
else
return
(
absoluteInstalledPackageInfo
pkg
ipid
lib
lbi
clbi
)
return
installedPkgInfo
{
IPI
.
installedPackageId
=
ipid
}
relocRegistrationInfo
::
Verbosity
->
PackageDescription
->
Library
->
LocalBuildInfo
->
ComponentLocalBuildInfo
->
InstalledPackageId
->
PackageDB
->
IO
InstalledPackageInfo
relocRegistrationInfo
verbosity
pkg
lib
lbi
clbi
ipid
packageDb
=
case
(
compilerFlavor
(
compiler
lbi
))
of
GHC
->
do
let
Just
ghcPkg
=
lookupProgram
ghcPkgProgram
(
withPrograms
lbi
)
fsM
<-
HcPkg
.
pkgRoot
verbosity
ghcPkg
packageDb
case
fsM
of
Just
fs
->
return
(
relocatableInstalledPackageInfo
pkg
ipid
lib
lbi
clbi
fs
)
Nothing
->
die
"Cannot register relocatable package with empty ${pkgroot}"
_
->
die
"Distribution.Simple.Register.relocRegistrationInfo:
\
\
not implemented for this compiler"
-- | Create an empty package DB at the specified location.
initPackageDB
::
Verbosity
->
Compiler
->
ProgramConfiguration
->
FilePath
...
...
@@ -383,8 +416,9 @@ relocatableInstalledPackageInfo :: PackageDescription
->
Library
->
LocalBuildInfo
->
ComponentLocalBuildInfo
->
FilePath
->
InstalledPackageInfo
relocatableInstalledPackageInfo
pkg
ipid
lib
lbi
clbi
=
relocatableInstalledPackageInfo
pkg
ipid
lib
lbi
clbi
pkgroot
=
generalInstalledPackageInfo
adjustReativeIncludeDirs
pkg
ipid
lib
lbi
clbi
installDirs
where
...
...
@@ -394,8 +428,9 @@ relocatableInstalledPackageInfo pkg ipid lib lbi clbi =
|
null
(
installIncludes
bi
)
=
[]
|
otherwise
=
[
includedir
installDirs
]
bi
=
libBuildInfo
lib
installDirs
=
fmap
((((
"${pkgroot}"
</>
".."
)
</>
".."
)
</>
)
.
fromJust
)
$
prefixRelativeInstallDirs
(
packageId
pkg
)
lbi
installDirs
=
fmap
((
"${pkgroot}"
</>
)
.
shortRelativePath
pkgroot
)
$
absoluteInstallDirs
pkg
lbi
NoCopyDest
-- -----------------------------------------------------------------------------
-- Unregistration
...
...
Cabal/Distribution/Simple/Utils.hs
View file @
717cf359
...
...
@@ -62,6 +62,7 @@ module Distribution.Simple.Utils (
-- * file names
currentDir
,
shortRelativePath
,
-- * finding files
findFile
,
...
...
@@ -150,7 +151,7 @@ import System.Exit
(
exitWith
,
ExitCode
(
..
)
)
import
System.FilePath
(
normalise
,
(
</>
),
(
<.>
)
,
getSearchPath
,
takeDirectory
,
splitFileName
,
getSearchPath
,
joinPath
,
takeDirectory
,
splitFileName
,
splitExtension
,
splitExtensions
,
splitDirectories
)
import
System.Directory
(
createDirectory
,
renameFile
,
removeDirectoryRecursive
)
...
...
@@ -1063,6 +1064,16 @@ rewriteFile path newContent =
currentDir
::
FilePath
currentDir
=
"."
shortRelativePath
::
FilePath
->
FilePath
->
FilePath
shortRelativePath
from
to
=
case
dropCommonPrefix
(
splitDirectories
from
)
(
splitDirectories
to
)
of
(
stuff
,
path
)
->
joinPath
(
map
(
const
".."
)
stuff
++
path
)
where
dropCommonPrefix
::
Eq
a
=>
[
a
]
->
[
a
]
->
([
a
],[
a
])
dropCommonPrefix
(
x
:
xs
)
(
y
:
ys
)
|
x
==
y
=
dropCommonPrefix
xs
ys
dropCommonPrefix
xs
ys
=
(
xs
,
ys
)
-- ------------------------------------------------------------
-- * Finding the description file
-- ------------------------------------------------------------
...
...
cabal-install/Distribution/Client/Install.hs
View file @
717cf359
...
...
@@ -1421,7 +1421,7 @@ installUnpackedPackage verbosity buildLimit installLock numJobs pkg_key
defInstallDirs
<-
InstallDirs
.
defaultInstallDirs
flavor
userInstall
False
return
$
configFlags'
{
configInstallDirs
=
fmap
Cabal
.
Flag
.
InstallDirs
.
substituteInstallDirTemplates
NP
env
$
InstallDirs
.
substituteInstallDirTemplates
env
$
InstallDirs
.
combineInstallDirs
fromFlagOrDefault
defInstallDirs
(
configInstallDirs
configFlags
)
}
...
...
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