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
d47cfcb8
Commit
d47cfcb8
authored
Nov 26, 2014
by
Christiaan Baaij
Browse files
Add support for relocatable Paths module
parent
aee97a5b
Changes
1
Hide whitespace changes
Inline
Side-by-side
Cabal/Distribution/Simple/Build/PathsModule.hs
View file @
d47cfcb8
...
...
@@ -32,6 +32,8 @@ import Distribution.Simple.LocalBuildInfo
import
Distribution.Simple.Setup
(
CopyDest
(
NoCopyDest
)
)
import
Distribution.Simple.BuildPaths
(
autogenModuleName
)
import
Distribution.Simple.Utils
(
shortRelativePath
)
import
Distribution.Text
(
display
)
import
Distribution.Version
...
...
@@ -62,6 +64,11 @@ generate pkg_descr lbi =
"import Foreign
\n
"
++
"import Foreign.C
\n
"
reloc_imports
|
reloc
=
"import System.Environment (getExecutablePath)
\n
"
|
otherwise
=
""
header
=
pragmas
++
"module "
++
display
paths_modulename
++
" (
\n
"
++
...
...
@@ -74,16 +81,36 @@ generate pkg_descr lbi =
"import qualified Control.Exception as Exception
\n
"
++
"import Data.Version (Version(..))
\n
"
++
"import System.Environment (getEnv)
\n
"
++
reloc_imports
++
"import Prelude
\n
"
++
"
\n
"
++
"catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
\n
"
++
"catchIO = Exception.catch
\n
"
++
"
\n
"
++
"
\n
version :: Version"
++
"version :: Version"
++
"
\n
version = Version "
++
show
branch
++
" "
++
show
tags
where
Version
branch
tags
=
packageVersion
pkg_descr
body
|
reloc
=
"
\n\n
bindirrel :: FilePath
\n
"
++
"bindirrel = "
++
show
flat_bindirreloc
++
"
\n
"
++
"
\n
getBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath
\n
"
++
"getBinDir = "
++
mkGetEnvOrReloc
"bindir"
flat_bindirreloc
++
"
\n
"
++
"getLibDir = "
++
mkGetEnvOrReloc
"libdir"
flat_libdirreloc
++
"
\n
"
++
"getDataDir = "
++
mkGetEnvOrReloc
"datadir"
flat_datadirreloc
++
"
\n
"
++
"getLibexecDir = "
++
mkGetEnvOrReloc
"libexecdir"
flat_libexecdirreloc
++
"
\n
"
++
"getSysconfDir = "
++
mkGetEnvOrReloc
"sysconfdir"
flat_sysconfdirreloc
++
"
\n
"
++
"
\n
"
++
"getDataFileName :: FilePath -> IO FilePath
\n
"
++
"getDataFileName name = do
\n
"
++
" dir <- getDataDir
\n
"
++
" return (dir `joinFileName` name)
\n
"
++
"
\n
"
++
get_prefix_reloc_stuff
++
"
\n
"
++
filename_stuff
|
absolute
=
"
\n
bindir, libdir, datadir, libexecdir, sysconfdir :: FilePath
\n
"
++
"
\n
bindir = "
++
show
flat_bindir
++
...
...
@@ -146,9 +173,20 @@ generate pkg_descr lbi =
sysconfdir
=
flat_sysconfdirrel
}
=
prefixRelativeInstallDirs
(
packageId
pkg_descr
)
lbi
flat_bindirreloc
=
shortRelativePath
flat_prefix
flat_bindir
flat_libdirreloc
=
shortRelativePath
flat_prefix
flat_libdir
flat_datadirreloc
=
shortRelativePath
flat_prefix
flat_datadir
flat_libexecdirreloc
=
shortRelativePath
flat_prefix
flat_libexecdir
flat_sysconfdirreloc
=
shortRelativePath
flat_prefix
flat_sysconfdir
mkGetDir
_
(
Just
dirrel
)
=
"getPrefixDirRel "
++
show
dirrel
mkGetDir
dir
Nothing
=
"return "
++
show
dir
mkGetEnvOrReloc
var
dirrel
=
"catchIO (getEnv
\"
"
++
var'
++
"
\"
)"
++
" (
\\
_ -> getPrefixDirReloc
\"
"
++
dirrel
++
"
\"
)"
where
var'
=
pkgPathEnvVar
pkg_descr
var
mkGetEnvOr
var
expr
=
"catchIO (getEnv
\"
"
++
var'
++
"
\"
)"
++
" (
\\
_ -> "
++
expr
++
")"
where
var'
=
pkgPathEnvVar
pkg_descr
var
...
...
@@ -159,6 +197,8 @@ generate pkg_descr lbi =
||
isNothing
flat_bindirrel
-- if the bin dir is an absolute path
||
not
(
supportsRelocatableProgs
(
compilerFlavor
(
compiler
lbi
)))
reloc
=
relocatable
lbi
supportsRelocatableProgs
GHC
=
case
buildOS
of
Windows
->
True
_
->
False
...
...
@@ -188,6 +228,15 @@ pkgPathEnvVar pkg_descr var =
fixchar
'-'
=
'_'
fixchar
c
=
c
get_prefix_reloc_stuff
::
String
get_prefix_reloc_stuff
=
"getPrefixDirReloc :: FilePath -> IO FilePath
\n
"
++
"getPrefixDirReloc dirRel = do
\n
"
++
" exePath <- getExecutablePath
\n
"
++
" let (bindir,_) = splitFileName exePath
\n
"
++
" return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)
\n
"
++
"
\n
"
get_prefix_win32
::
Arch
->
String
get_prefix_win32
arch
=
"getPrefixDirRel :: FilePath -> IO FilePath
\n
"
++
...
...
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