Commit 988c9a69 authored by Francesco Gazzetta's avatar Francesco Gazzetta

Correctly compute new-install paths on windows

some platforms need an extension for executables

Fixed how we get the bindir too.
parent 344c07ef
......@@ -52,6 +52,8 @@ import Distribution.Client.ProjectConfig.Types
import Distribution.Simple.Program.Db
( userSpecifyPaths, userSpecifyArgss, defaultProgramDb
, modifyProgramSearchPath, ProgramDb )
import Distribution.Simple.BuildPaths
( exeExtension )
import Distribution.Simple.Program.Find
( ProgramSearchPathEntry(..) )
import Distribution.Client.Config
......@@ -72,10 +74,13 @@ import Distribution.Client.IndexUtils
import Distribution.Client.ProjectConfig
( readGlobalConfig, projectConfigWithBuilderRepoContext
, resolveBuildTimeSettings, withProjectOrGlobalConfig )
import Distribution.Client.ProjectPlanning
( storePackageInstallDirs' )
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Client.DistDirLayout
( defaultDistDirLayout, DistDirLayout(..), mkCabalDirLayout
, ProjectRoot(ProjectRootImplicit)
, storePackageDirectory, cabalStoreDirLayout
, cabalStoreDirLayout
, CabalDirLayout(..), StoreDirLayout(..) )
import Distribution.Client.RebuildMonad
( runRebuild )
......@@ -97,10 +102,12 @@ import Distribution.Simple.GHC
, GhcImplInfo(..), getImplInfo
, GhcEnvironmentFileEntry(..)
, renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )
import Distribution.System
( Platform )
import Distribution.Types.UnitId
( UnitId )
import Distribution.Types.UnqualComponentName
( UnqualComponentName, unUnqualComponentName )
( UnqualComponentName, unUnqualComponentName, mkUnqualComponentName )
import Distribution.Verbosity
( Verbosity, normal, lessVerbose )
import Distribution.Simple.Utils
......@@ -131,7 +138,7 @@ import System.Directory
, getTemporaryDirectory, makeAbsolute, doesDirectoryExist
, removeFile, removeDirectory, copyFile )
import System.FilePath
( (</>), takeDirectory, takeBaseName )
( (</>), (<.>), takeDirectory, takeBaseName )
installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
......@@ -548,7 +555,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
when (not dryRun) $
if installLibs
then installLibraries verbosity buildCtx compiler packageDbs progDb envFile envEntries'
else installExes verbosity baseCtx buildCtx compiler clientInstallFlags
else installExes verbosity baseCtx buildCtx platform compiler clientInstallFlags
where
configFlags' = disableTestsBenchsByDefault configFlags
verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
......@@ -559,18 +566,24 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
-- | Install any built exe by symlinking/copying it
-- we don't use BuildOutcomes because we also need the component names
installExes :: Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> Platform
-> Compiler
-> ClientInstallFlags
-> IO ()
installExes verbosity baseCtx buildCtx compiler clientInstallFlags = do
-- XXX The comment in InstallSymlink.hs (pkgBinDir) says this is too naive (and it is)
let mkPkgBinDir = (</> "bin") .
storePackageDirectory
(cabalStoreDirLayout $ cabalDirLayout baseCtx)
(compilerId compiler)
installExes verbosity baseCtx buildCtx platform compiler
clientInstallFlags = do
let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx
let mkPkgBinDir :: UnitId -> FilePath
mkPkgBinDir = InstallDirs.bindir .
storePackageInstallDirs'
storeDirLayout
(compilerId compiler)
mkExeName :: UnqualComponentName -> FilePath
mkExeName exe = unUnqualComponentName exe <.> exeExtension platform
installdirUnknown =
"installdir is not defined. Set it in your cabal config file "
++ "or use --installdir=<path>"
......@@ -582,7 +595,8 @@ installExes verbosity baseCtx buildCtx compiler clientInstallFlags = do
doInstall = installPackageExes
verbosity
overwritePolicy
mkPkgBinDir installdir installMethod
mkPkgBinDir mkExeName
installdir installMethod
in traverse_ doInstall $ Map.toList $ targetsMap buildCtx
where
overwritePolicy = fromFlagOrDefault NeverOverwrite
......@@ -673,17 +687,20 @@ disableTestsBenchsByDefault configFlags =
, configBenchmarks = Flag False <> configBenchmarks configFlags }
-- | Symlink/copy every exe from a package from the store to a given location
-- TODO s/Package/Unit/ s/pkg/unit/
installPackageExes :: Verbosity
-> OverwritePolicy -- ^ Whether to overwrite existing files
-> (UnitId -> FilePath) -- ^ A function to get an UnitId's
-- store directory
-> (UnqualComponentName -> FilePath) -- ^ A function to get
-- ^ an exe's filename
-> FilePath
-> InstallMethod
-> ( UnitId
, [(ComponentTarget, [TargetSelector])] )
-> IO ()
installPackageExes verbosity overwritePolicy
mkSourceBinDir
mkSourceBinDir mkExeName
installdir installMethod
(pkg, components) =
traverse_ installAndWarn exes
......@@ -694,7 +711,7 @@ installPackageExes verbosity overwritePolicy
installAndWarn exe = do
success <- installBuiltExe
verbosity overwritePolicy
(mkSourceBinDir pkg) exe
(mkSourceBinDir pkg) (mkExeName exe)
installdir installMethod
let errorMessage = case overwritePolicy of
NeverOverwrite ->
......@@ -710,32 +727,31 @@ installPackageExes verbosity overwritePolicy
-- | Install a specific exe.
installBuiltExe :: Verbosity -> OverwritePolicy
-> FilePath
-> UnqualComponentName
-> FilePath
-> FilePath -- ^ The directory where the built exe is located
-> FilePath -- ^ The exe's filename
-> FilePath -- ^ the directory where it should be installed
-> InstallMethod
-> IO Bool
-> IO Bool -- ^ Whether the installation was successful
installBuiltExe verbosity overwritePolicy
sourceDir exe
sourceDir exeName
installdir InstallMethodSymlink = do
notice verbosity $ "Symlinking '" <> prettyShow exe <> "'"
notice verbosity $ "Symlinking '" <> exeName <> "'"
symlinkBinary
overwritePolicy
installdir
sourceDir
exe
$ unUnqualComponentName exe
(mkUnqualComponentName exeName)
exeName
installBuiltExe verbosity overwritePolicy
sourceDir exe
sourceDir exeName
installdir InstallMethodCopy = do
notice verbosity $ "Copying '" <> prettyShow exe <> "'"
notice verbosity $ "Copying '" <> exeName <> "'"
exists <- doesPathExist destination
case (exists, overwritePolicy) of
(True , NeverOverwrite ) -> pure False
(True , AlwaysOverwrite) -> remove >> copy
(False, _ ) -> copy
where
exeName = unUnqualComponentName exe
source = sourceDir </> exeName
destination = installdir </> exeName
remove = do
......
......@@ -62,7 +62,9 @@ module Distribution.Client.ProjectPlanning (
-- * Path construction
binDirectoryFor,
binDirectories
binDirectories,
storePackageInstallDirs,
storePackageInstallDirs'
) where
import Prelude ()
......@@ -3183,13 +3185,20 @@ storePackageInstallDirs :: StoreDirLayout
-> CompilerId
-> InstalledPackageId
-> InstallDirs.InstallDirs FilePath
storePackageInstallDirs StoreDirLayout{ storePackageDirectory
, storeDirectory }
compid ipkgid =
storePackageInstallDirs storeDirLayout compid ipkgid =
storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid
storePackageInstallDirs' :: StoreDirLayout
-> CompilerId
-> UnitId
-> InstallDirs.InstallDirs FilePath
storePackageInstallDirs' StoreDirLayout{ storePackageDirectory
, storeDirectory }
compid unitid =
InstallDirs.InstallDirs {..}
where
store = storeDirectory compid
prefix = storePackageDirectory compid (newSimpleUnitId ipkgid)
prefix = storePackageDirectory compid unitid
bindir = prefix </> "bin"
libdir = prefix </> "lib"
libsubdir = ""
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment