Commit fa27bd87 authored by fendor's avatar fendor

Honour suffix and prefix on install

Previously, the flags --program-suffix and --program-prefix
was ignored when given to v2-install.
To fix this, both installation cases, symlink and copy need to be
aware of the new installation name.
parent 773ad13a
......@@ -107,7 +107,7 @@ import Distribution.System
import Distribution.Types.UnitId
( UnitId )
import Distribution.Types.UnqualComponentName
( UnqualComponentName, unUnqualComponentName, mkUnqualComponentName )
( UnqualComponentName, unUnqualComponentName )
import Distribution.Verbosity
( Verbosity, normal, lessVerbose )
import Distribution.Simple.Utils
......@@ -590,7 +590,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
then installLibraries verbosity
buildCtx compiler packageDbs progDb envFile envEntries'
else installExes verbosity
baseCtx buildCtx platform compiler clientInstallFlags
baseCtx buildCtx platform compiler configFlags clientInstallFlags
where
configFlags' = disableTestsBenchsByDefault configFlags
verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
......@@ -608,12 +608,16 @@ installExes
-> ProjectBuildContext
-> Platform
-> Compiler
-> ConfigFlags
-> ClientInstallFlags
-> IO ()
installExes verbosity baseCtx buildCtx platform compiler
clientInstallFlags = do
configFlags clientInstallFlags = do
let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx
prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))
suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags))
mkUnitBinDir :: UnitId -> FilePath
mkUnitBinDir =
InstallDirs.bindir .
......@@ -621,6 +625,9 @@ installExes verbosity baseCtx buildCtx platform compiler
mkExeName :: UnqualComponentName -> FilePath
mkExeName exe = unUnqualComponentName exe <.> exeExtension platform
mkFinalExeName :: UnqualComponentName -> FilePath
mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform
installdirUnknown =
"installdir is not defined. Set it in your cabal config file "
++ "or use --installdir=<path>"
......@@ -633,7 +640,7 @@ installExes verbosity baseCtx buildCtx platform compiler
doInstall = installUnitExes
verbosity
overwritePolicy
mkUnitBinDir mkExeName
mkUnitBinDir mkExeName mkFinalExeName
installdir installMethod
in traverse_ doInstall $ Map.toList $ targetsMap buildCtx
where
......@@ -736,13 +743,16 @@ installUnitExes
-- ^ store directory
-> (UnqualComponentName -> FilePath) -- ^ A function to get an
-- ^ exe's filename
-> (UnqualComponentName -> FilePath) -- ^ A function to get an
-- ^ exe's final possibly
-- ^ different to the name in the store.
-> FilePath
-> InstallMethod
-> ( UnitId
, [(ComponentTarget, [TargetSelector])] )
-> IO ()
installUnitExes verbosity overwritePolicy
mkSourceBinDir mkExeName
mkSourceBinDir mkExeName mkFinalExeName
installdir installMethod
(unit, components) =
traverse_ installAndWarn exes
......@@ -754,6 +764,7 @@ installUnitExes verbosity overwritePolicy
success <- installBuiltExe
verbosity overwritePolicy
(mkSourceBinDir unit) (mkExeName exe)
(mkFinalExeName exe)
installdir installMethod
let errorMessage = case overwritePolicy of
NeverOverwrite ->
......@@ -773,21 +784,22 @@ installBuiltExe
:: Verbosity -> OverwritePolicy
-> FilePath -- ^ The directory where the built exe is located
-> FilePath -- ^ The exe's filename
-> FilePath -- ^ The exe's filename in the public install directory
-> FilePath -- ^ the directory where it should be installed
-> InstallMethod
-> IO Bool -- ^ Whether the installation was successful
installBuiltExe verbosity overwritePolicy
sourceDir exeName
sourceDir exeName finalExeName
installdir InstallMethodSymlink = do
notice verbosity $ "Symlinking '" <> exeName <> "'"
symlinkBinary
overwritePolicy
installdir
sourceDir
(mkUnqualComponentName exeName)
finalExeName
exeName
installBuiltExe verbosity overwritePolicy
sourceDir exeName
sourceDir exeName finalExeName
installdir InstallMethodCopy = do
notice verbosity $ "Copying '" <> exeName <> "'"
exists <- doesPathExist destination
......@@ -797,7 +809,7 @@ installBuiltExe verbosity overwritePolicy
(False, _ ) -> copy
where
source = sourceDir </> exeName
destination = installdir </> exeName
destination = installdir </> finalExeName
remove = do
isDir <- doesDirectoryExist destination
if isDir
......
......@@ -48,7 +48,7 @@ symlinkBinaries :: Platform -> Compiler
symlinkBinaries _ _ _ _ _ _ _ = return []
symlinkBinary :: OverwritePolicy
-> FilePath -> FilePath -> UnqualComponentName -> String
-> FilePath -> FilePath -> FilePath -> String
-> IO Bool
symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows"
......@@ -154,7 +154,7 @@ symlinkBinaries platform comp overwritePolicy
ok <- symlinkBinary
overwritePolicy
publicBinDir privateBinDir
publicExeName privateExeName
(display publicExeName) privateExeName
if ok
then return Nothing
else return (Just (pkgid, publicExeName,
......@@ -220,7 +220,7 @@ symlinkBinary ::
-- @/home/user/bin@
-> FilePath -- ^ The canonical path of the private bin dir eg
-- @/home/user/.cabal/bin@
-> UnqualComponentName -- ^ The name of the executable to go in the public bin
-> FilePath -- ^ The name of the executable to go in the public bin
-- dir, eg @foo@
-> String -- ^ The name of the executable to in the private bin
-- dir, eg @foo-1.0@
......@@ -229,7 +229,7 @@ symlinkBinary ::
-- not own. Other errors like permission errors just
-- propagate as exceptions.
symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do
ok <- targetOkToOverwrite (publicBindir </> publicName')
ok <- targetOkToOverwrite (publicBindir </> publicName)
(privateBindir </> privateName)
case ok of
NotExists -> mkLink >> return True
......@@ -239,11 +239,10 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName
NeverOverwrite -> return False
AlwaysOverwrite -> rmLink >> mkLink >> return True
where
publicName' = display publicName
relativeBindir = makeRelative publicBindir privateBindir
mkLink = createSymbolicLink (relativeBindir </> privateName)
(publicBindir </> publicName')
rmLink = removeLink (publicBindir </> publicName')
(publicBindir </> publicName)
rmLink = removeLink (publicBindir </> publicName)
-- | Check a file path of a symlink that we would like to create to see if it
-- is OK. For it to be OK to overwrite it must either not already exist yet or
......
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