Commit 344c07ef authored by Francesco Gazzetta's avatar Francesco Gazzetta

Add install-method, put new-install flags in config

Add an --install-method=symlink|copy flag which specifies how to perform
the installation.

* --symlink-bindir is now gone, replaced by --installdir
* --install-method=copy is useful in Windows where symlinking is not
supported

All new-install flags can now be configured in ~/.cabal/config

* NewInstallFlags changed to ClientInstallFlags (more descriptive than
InstallExFlags (like ConfigExFlags))
* ClientInstallFlags is now part of SavedConfig
parent 273dacfd
...@@ -117,7 +117,9 @@ benchAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) ...@@ -117,7 +117,9 @@ benchAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)
verbosity = fromFlagOrDefault normal (configVerbosity configFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags globalFlags configFlags configExFlags
installFlags haddockFlags testFlags installFlags
mempty -- ClientInstallFlags, not needed here
haddockFlags testFlags
-- | This defines what a 'TargetSelector' means for the @bench@ command. -- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
......
...@@ -157,7 +157,9 @@ buildAction ...@@ -157,7 +157,9 @@ buildAction
verbosity = fromFlagOrDefault normal (configVerbosity configFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags globalFlags configFlags configExFlags
installFlags haddockFlags testFlags installFlags
mempty -- ClientInstallFlags, not needed here
haddockFlags testFlags
-- | This defines what a 'TargetSelector' means for the @bench@ command. -- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
......
...@@ -121,5 +121,7 @@ configureAction (configFlags, configExFlags, installFlags, haddockFlags, testFla ...@@ -121,5 +121,7 @@ configureAction (configFlags, configExFlags, installFlags, haddockFlags, testFla
verbosity = fromFlagOrDefault normal (configVerbosity configFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags globalFlags configFlags configExFlags
installFlags haddockFlags testFlags installFlags
mempty -- ClientInstallFlags, not needed here
haddockFlags testFlags
...@@ -194,7 +194,9 @@ execAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) ...@@ -194,7 +194,9 @@ execAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)
verbosity = fromFlagOrDefault normal (configVerbosity configFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags globalFlags configFlags configExFlags
installFlags haddockFlags testFlags installFlags
mempty -- ClientInstallFlags, not needed here
haddockFlags testFlags
withOverrides env args program = program withOverrides env args program = program
{ programOverrideEnv = programOverrideEnv program ++ env { programOverrideEnv = programOverrideEnv program ++ env
, programDefaultArgs = programDefaultArgs program ++ args} , programDefaultArgs = programDefaultArgs program ++ args}
......
...@@ -130,7 +130,9 @@ freezeAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) ...@@ -130,7 +130,9 @@ freezeAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)
verbosity = fromFlagOrDefault normal (configVerbosity configFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags globalFlags configFlags configExFlags
installFlags haddockFlags testFlags installFlags
mempty -- ClientInstallFlags, not needed here
haddockFlags testFlags
......
...@@ -111,7 +111,9 @@ haddockAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags ...@@ -111,7 +111,9 @@ haddockAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
verbosity = fromFlagOrDefault normal (configVerbosity configFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags globalFlags configFlags configExFlags
installFlags haddockFlags testFlags installFlags
mempty -- ClientInstallFlags, not needed here
haddockFlags testFlags
-- | This defines what a 'TargetSelector' means for the @haddock@ command. -- | This defines what a 'TargetSelector' means for the @haddock@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
......
...@@ -20,11 +20,15 @@ module Distribution.Client.CmdInstall ( ...@@ -20,11 +20,15 @@ module Distribution.Client.CmdInstall (
import Prelude () import Prelude ()
import Distribution.Client.Compat.Prelude import Distribution.Client.Compat.Prelude
import Distribution.Compat.Directory
( doesPathExist )
import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages import Distribution.Client.CmdErrorMessages
import Distribution.Client.CmdSdist import Distribution.Client.CmdSdist
import Distribution.Client.CmdInstall.ClientInstallFlags
import Distribution.Client.Setup import Distribution.Client.Setup
( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..)
, configureExOptions, haddockOptions, installOptions, testOptions , configureExOptions, haddockOptions, installOptions, testOptions
...@@ -51,7 +55,7 @@ import Distribution.Simple.Program.Db ...@@ -51,7 +55,7 @@ import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Find import Distribution.Simple.Program.Find
( ProgramSearchPathEntry(..) ) ( ProgramSearchPathEntry(..) )
import Distribution.Client.Config import Distribution.Client.Config
( getCabalDir ) ( getCabalDir, loadConfig, SavedConfig(..) )
import qualified Distribution.Simple.PackageIndex as PI import qualified Distribution.Simple.PackageIndex as PI
import Distribution.Solver.Types.PackageIndex import Distribution.Solver.Types.PackageIndex
( lookupPackageName, searchByName ) ( lookupPackageName, searchByName )
...@@ -78,15 +82,11 @@ import Distribution.Client.RebuildMonad ...@@ -78,15 +82,11 @@ import Distribution.Client.RebuildMonad
import Distribution.Client.InstallSymlink import Distribution.Client.InstallSymlink
( OverwritePolicy(..), symlinkBinary ) ( OverwritePolicy(..), symlinkBinary )
import Distribution.Simple.Setup import Distribution.Simple.Setup
( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe ( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe )
, trueArg, flagToList, toFlag )
import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.SourcePackage
( SourcePackage(..) ) ( SourcePackage(..) )
import Distribution.ReadE
( ReadE(..), succeedReadE )
import Distribution.Simple.Command import Distribution.Simple.Command
( CommandUI(..), ShowOrParseArgs(..), OptionField(..) ( CommandUI(..), OptionField(..), usageAlternatives )
, option, usageAlternatives, reqArg )
import Distribution.Simple.Configure import Distribution.Simple.Configure
( configCompilerEx ) ( configCompilerEx )
import Distribution.Simple.Compiler import Distribution.Simple.Compiler
...@@ -128,52 +128,14 @@ import Distribution.Utils.NubList ...@@ -128,52 +128,14 @@ import Distribution.Utils.NubList
( fromNubList ) ( fromNubList )
import System.Directory import System.Directory
( getHomeDirectory, doesFileExist, createDirectoryIfMissing ( getHomeDirectory, doesFileExist, createDirectoryIfMissing
, getTemporaryDirectory, makeAbsolute, doesDirectoryExist ) , getTemporaryDirectory, makeAbsolute, doesDirectoryExist
, removeFile, removeDirectory, copyFile )
import System.FilePath import System.FilePath
( (</>), takeDirectory, takeBaseName ) ( (</>), takeDirectory, takeBaseName )
data NewInstallFlags = NewInstallFlags
{ ninstInstallLibs :: Flag Bool
, ninstEnvironmentPath :: Flag FilePath
, ninstOverwritePolicy :: Flag OverwritePolicy
}
defaultNewInstallFlags :: NewInstallFlags
defaultNewInstallFlags = NewInstallFlags
{ ninstInstallLibs = toFlag False
, ninstEnvironmentPath = mempty
, ninstOverwritePolicy = toFlag NeverOverwrite
}
newInstallOptions :: ShowOrParseArgs -> [OptionField NewInstallFlags]
newInstallOptions _ =
[ option [] ["lib"]
"Install libraries rather than executables from the target package."
ninstInstallLibs (\v flags -> flags { ninstInstallLibs = v })
trueArg
, option [] ["package-env", "env"]
"Set the environment file that may be modified."
ninstEnvironmentPath (\pf flags -> flags { ninstEnvironmentPath = pf })
(reqArg "ENV" (succeedReadE Flag) flagToList)
, option [] ["overwrite-policy"]
"How to handle already existing symlinks."
ninstOverwritePolicy (\v flags -> flags { ninstOverwritePolicy = v })
$ reqArg
"always|never"
readOverwritePolicyFlag
showOverwritePolicyFlag
]
where
readOverwritePolicyFlag = ReadE $ \case
"always" -> Right $ Flag AlwaysOverwrite
"never" -> Right $ Flag NeverOverwrite
policy -> Left $ "'" <> policy <> "' isn't a valid overwrite policy"
showOverwritePolicyFlag (Flag AlwaysOverwrite) = ["always"]
showOverwritePolicyFlag (Flag NeverOverwrite) = ["never"]
showOverwritePolicyFlag NoFlag = []
installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
, HaddockFlags, TestFlags, NewInstallFlags , HaddockFlags, TestFlags, ClientInstallFlags
) )
installCommand = CommandUI installCommand = CommandUI
{ commandName = "v2-install" { commandName = "v2-install"
...@@ -182,8 +144,8 @@ installCommand = CommandUI ...@@ -182,8 +144,8 @@ installCommand = CommandUI
"v2-install" [ "[TARGETS] [FLAGS]" ] "v2-install" [ "[TARGETS] [FLAGS]" ]
, commandDescription = Just $ \_ -> wrapText $ , commandDescription = Just $ \_ -> wrapText $
"Installs one or more packages. This is done by installing them " "Installs one or more packages. This is done by installing them "
++ "in the store and symlinking the executables in the directory " ++ "in the store and symlinking/copying the executables in the directory "
++ "specified by the --symlink-bindir flag (`~/.cabal/bin/` by default). " ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). "
++ "If you want the installed executables to be available globally, " ++ "If you want the installed executables to be available globally, "
++ "make sure that the PATH environment variable contains that directory. " ++ "make sure that the PATH environment variable contains that directory. "
++ "\n\n" ++ "\n\n"
...@@ -211,9 +173,10 @@ installCommand = CommandUI ...@@ -211,9 +173,10 @@ installCommand = CommandUI
. optionName) $ configureOptions showOrParseArgs) . optionName) $ configureOptions showOrParseArgs)
++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
++ liftOptions get3 set3 ++ liftOptions get3 set3
-- hide "target-package-db" flag from the -- hide "target-package-db" and "symlink-bindir" flags from the
-- install options. -- install options.
(filter ((`notElem` ["target-package-db"]) -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags
(filter ((`notElem` ["target-package-db", "symlink-bindir"])
. optionName) $ . optionName) $
installOptions showOrParseArgs) installOptions showOrParseArgs)
++ liftOptions get4 set4 ++ liftOptions get4 set4
...@@ -223,8 +186,8 @@ installCommand = CommandUI ...@@ -223,8 +186,8 @@ installCommand = CommandUI
. optionName) $ . optionName) $
haddockOptions showOrParseArgs) haddockOptions showOrParseArgs)
++ liftOptions get5 set5 (testOptions showOrParseArgs) ++ liftOptions get5 set5 (testOptions showOrParseArgs)
++ liftOptions get6 set6 (newInstallOptions showOrParseArgs) ++ liftOptions get6 set6 (clientInstallOptions showOrParseArgs)
, commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, defaultNewInstallFlags) , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, defaultClientInstallFlags)
} }
where where
get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f)
...@@ -241,7 +204,7 @@ installCommand = CommandUI ...@@ -241,7 +204,7 @@ installCommand = CommandUI
-- install command, except that now conflicts between separate runs of the -- install command, except that now conflicts between separate runs of the
-- command are impossible thanks to the store. -- command are impossible thanks to the store.
-- Exes are installed in the store like a normal dependency, then they are -- Exes are installed in the store like a normal dependency, then they are
-- symlinked uin the directory specified by --symlink-bindir. -- symlinked/copied in the directory specified by --installdir.
-- To do this we need a dummy projectBaseContext containing the targets as -- To do this we need a dummy projectBaseContext containing the targets as
-- estra packages and using a temporary dist directory. -- estra packages and using a temporary dist directory.
-- * libraries -- * libraries
...@@ -252,9 +215,9 @@ installCommand = CommandUI ...@@ -252,9 +215,9 @@ installCommand = CommandUI
-- For more details on how this works, see the module -- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration" -- "Distribution.Client.ProjectOrchestration"
-- --
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, NewInstallFlags) installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ClientInstallFlags)
-> [String] -> GlobalFlags -> IO () -> [String] -> GlobalFlags -> IO ()
installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, newInstallFlags) installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, clientInstallFlags')
targetStrings globalFlags = do targetStrings globalFlags = do
-- We never try to build tests/benchmarks for remote packages. -- We never try to build tests/benchmarks for remote packages.
-- So we set them as disabled by default and error if they are explicitly -- So we set them as disabled by default and error if they are explicitly
...@@ -266,6 +229,14 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags ...@@ -266,6 +229,14 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "
++ "be enabled in a remote package" ++ "be enabled in a remote package"
-- We cannot use establishDummyProjectBaseContext to get these flags, since
-- it requires one of them as an argument. Normal establishProjectBaseContext
-- does not, and this is why this is done only for the install command
clientInstallFlags <- do
let configFileFlag = globalConfigFile globalFlags
savedConfig <- loadConfig verbosity configFileFlag
pure $ savedClientInstallFlags savedConfig `mappend` clientInstallFlags'
let let
withProject = do withProject = do
let verbosity' = lessVerbose verbosity let verbosity' = lessVerbose verbosity
...@@ -485,7 +456,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags ...@@ -485,7 +456,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
GhcEnvFilePackageId _ -> True GhcEnvFilePackageId _ -> True
_ -> False _ -> False
envFile <- case flagToMaybe (ninstEnvironmentPath newInstallFlags) of envFile <- case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of
Just spec Just spec
-- Is spec a bare word without any "pathy" content, then it refers to -- Is spec a bare word without any "pathy" content, then it refers to
-- a named global environment. -- a named global environment.
...@@ -571,52 +542,53 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags ...@@ -571,52 +542,53 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags
-- First, figure out if / what parts we want to install: -- First, figure out if / what parts we want to install:
let let
dryRun = buildSettingDryRun $ buildSettings baseCtx dryRun = buildSettingDryRun $ buildSettings baseCtx
installLibs = fromFlagOrDefault False (ninstInstallLibs newInstallFlags) installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)
-- Then, install! -- Then, install!
when (not dryRun) $ when (not dryRun) $
if installLibs if installLibs
then installLibraries verbosity buildCtx compiler packageDbs progDb envFile envEntries' then installLibraries verbosity buildCtx compiler packageDbs progDb envFile envEntries'
else installExes verbosity baseCtx buildCtx compiler newInstallFlags else installExes verbosity baseCtx buildCtx compiler clientInstallFlags
where where
configFlags' = disableTestsBenchsByDefault configFlags configFlags' = disableTestsBenchsByDefault configFlags
verbosity = fromFlagOrDefault normal (configVerbosity configFlags') verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
cliConfig = commandLineFlagsToProjectConfig cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags' configExFlags globalFlags configFlags' configExFlags
installFlags haddockFlags testFlags installFlags clientInstallFlags'
haddockFlags testFlags
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
-- | Install any built exe by symlinking it -- | Install any built exe by symlinking/copying it
installExes :: Verbosity installExes :: Verbosity
-> ProjectBaseContext -> ProjectBaseContext
-> ProjectBuildContext -> ProjectBuildContext
-> Compiler -> Compiler
-> NewInstallFlags -> ClientInstallFlags
-> IO () -> IO ()
installExes verbosity baseCtx buildCtx compiler newInstallFlags = do 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") . let mkPkgBinDir = (</> "bin") .
storePackageDirectory storePackageDirectory
(cabalStoreDirLayout $ cabalDirLayout baseCtx) (cabalStoreDirLayout $ cabalDirLayout baseCtx)
(compilerId compiler) (compilerId compiler)
symlinkBindirUnknown = installdirUnknown =
"symlink-bindir is not defined. Set it in your cabal config file " "installdir is not defined. Set it in your cabal config file "
++ "or use --symlink-bindir=<path>" ++ "or use --installdir=<path>"
symlinkBindir <- fromFlagOrDefault (die' verbosity symlinkBindirUnknown) installdir <- fromFlagOrDefault (die' verbosity installdirUnknown)
$ fmap makeAbsolute $ pure <$> cinstInstalldir clientInstallFlags
$ projectConfigSymlinkBinDir createDirectoryIfMissingVerbose verbosity False installdir
$ projectConfigBuildOnly
$ projectConfig baseCtx
createDirectoryIfMissingVerbose verbosity False symlinkBindir
warnIfNoExes verbosity buildCtx warnIfNoExes verbosity buildCtx
let let
doSymlink = symlinkBuiltPackage doInstall = installPackageExes
verbosity verbosity
overwritePolicy overwritePolicy
mkPkgBinDir symlinkBindir mkPkgBinDir installdir installMethod
in traverse_ doSymlink $ Map.toList $ targetsMap buildCtx in traverse_ doInstall $ Map.toList $ targetsMap buildCtx
where where
overwritePolicy = fromFlagOrDefault NeverOverwrite overwritePolicy = fromFlagOrDefault NeverOverwrite
$ ninstOverwritePolicy newInstallFlags $ cinstOverwritePolicy clientInstallFlags
installMethod = fromFlagOrDefault InstallMethodSymlink
$ cinstInstallMethod clientInstallFlags
-- | Install any built library by adding it to the default ghc environment -- | Install any built library by adding it to the default ghc environment
installLibraries :: Verbosity installLibraries :: Verbosity
...@@ -700,49 +672,78 @@ disableTestsBenchsByDefault configFlags = ...@@ -700,49 +672,78 @@ disableTestsBenchsByDefault configFlags =
configFlags { configTests = Flag False <> configTests configFlags configFlags { configTests = Flag False <> configTests configFlags
, configBenchmarks = Flag False <> configBenchmarks configFlags } , configBenchmarks = Flag False <> configBenchmarks configFlags }
-- | Symlink every exe from a package from the store to a given location -- | Symlink/copy every exe from a package from the store to a given location
symlinkBuiltPackage :: Verbosity installPackageExes :: Verbosity
-> OverwritePolicy -- ^ Whether to overwrite existing files -> OverwritePolicy -- ^ Whether to overwrite existing files
-> (UnitId -> FilePath) -- ^ A function to get an UnitId's -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
-- store directory -- store directory
-> FilePath -- ^ Where to put the symlink -> FilePath
-> ( UnitId -> InstallMethod
, [(ComponentTarget, [TargetSelector])] ) -> ( UnitId
-> IO () , [(ComponentTarget, [TargetSelector])] )
symlinkBuiltPackage verbosity overwritePolicy -> IO ()
mkSourceBinDir destDir installPackageExes verbosity overwritePolicy
(pkg, components) = mkSourceBinDir
traverse_ symlinkAndWarn exes installdir installMethod
(pkg, components) =
traverse_ installAndWarn exes
where where
exes = catMaybes $ (exeMaybe . fst) <$> components exes = catMaybes $ (exeMaybe . fst) <$> components
exeMaybe (ComponentTarget (CExeName exe) _) = Just exe exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
exeMaybe _ = Nothing exeMaybe _ = Nothing
symlinkAndWarn exe = do installAndWarn exe = do
success <- symlinkBuiltExe success <- installBuiltExe
verbosity overwritePolicy verbosity overwritePolicy
(mkSourceBinDir pkg) destDir exe (mkSourceBinDir pkg) exe
installdir installMethod
let errorMessage = case overwritePolicy of let errorMessage = case overwritePolicy of
NeverOverwrite -> NeverOverwrite ->
"Path '" <> (destDir </> prettyShow exe) <> "' already exists. " "Path '" <> (installdir </> prettyShow exe) <> "' already exists. "
<> "Use --overwrite-policy=always to overwrite." <> "Use --overwrite-policy=always to overwrite."
-- This shouldn't even be possible, but we keep it in case -- This shouldn't even be possible, but we keep it in case
-- symlinking logic changes -- symlinking/copying logic changes
AlwaysOverwrite -> "Symlinking '" <> prettyShow exe <> "' failed." AlwaysOverwrite -> case installMethod of
InstallMethodSymlink -> "Symlinking"
InstallMethodCopy -> "Copying"
<> " '" <> prettyShow exe <> "' failed."
unless success $ die' verbosity errorMessage unless success $ die' verbosity errorMessage
-- | Symlink a specific exe. -- | Install a specific exe.
symlinkBuiltExe :: Verbosity -> OverwritePolicy installBuiltExe :: Verbosity -> OverwritePolicy
-> FilePath -> FilePath -> FilePath
-> UnqualComponentName -> UnqualComponentName
-> FilePath
-> InstallMethod
-> IO Bool -> IO Bool
symlinkBuiltExe verbosity overwritePolicy sourceDir destDir exe = do installBuiltExe verbosity overwritePolicy
sourceDir exe
installdir InstallMethodSymlink = do
notice verbosity $ "Symlinking '" <> prettyShow exe <> "'" notice verbosity $ "Symlinking '" <> prettyShow exe <> "'"
symlinkBinary symlinkBinary
overwritePolicy overwritePolicy
destDir installdir
sourceDir sourceDir
exe exe
$ unUnqualComponentName exe $ unUnqualComponentName exe
installBuiltExe verbosity overwritePolicy
sourceDir exe
installdir InstallMethodCopy = do
notice verbosity $ "Copying '" <> prettyShow exe <> "'"
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
isDir <- doesDirectoryExist destination
if isDir
then removeDirectory destination
else removeFile destination
copy = copyFile source destination >> pure True
-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
module Distribution.Client.CmdInstall.ClientInstallFlags
( InstallMethod(..)
, ClientInstallFlags(..)
, defaultClientInstallFlags
, clientInstallOptions
) where
import Distribution.Client.Compat.Prelude
import Distribution.ReadE
( ReadE(..), succeedReadE )
import Distribution.Simple.Command
( ShowOrParseArgs(..), OptionField(..), option, reqArg )
import Distribution.Simple.Setup
( Flag(..), trueArg, flagToList, toFlag )
import Distribution.Client.InstallSymlink
( OverwritePolicy(..) )
data InstallMethod = InstallMethodCopy
| InstallMethodSymlink
deriving (Eq, Show, Generic, Bounded, Enum)
instance Binary InstallMethod
data ClientInstallFlags = ClientInstallFlags
{ cinstInstallLibs :: Flag Bool
, cinstEnvironmentPath :: Flag FilePath
, cinstOverwritePolicy :: Flag OverwritePolicy
, cinstInstallMethod :: Flag InstallMethod
, cinstInstalldir :: Flag FilePath
} deriving (Eq, Show, Generic)
instance Monoid ClientInstallFlags where
mempty = gmempty
mappend = (<>)
instance Semigroup ClientInstallFlags where
(<>) = gmappend
instance Binary ClientInstallFlags
defaultClientInstallFlags :: ClientInstallFlags
defaultClientInstallFlags = ClientInstallFlags
{ cinstInstallLibs = toFlag False
, cinstEnvironmentPath = mempty
, cinstOverwritePolicy = toFlag NeverOverwrite
, cinstInstallMethod = toFlag InstallMethodSymlink
, cinstInstalldir = mempty
}
clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions _ =
[ option [] ["lib"]
"Install libraries rather than executables from the target package."
cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v })
trueArg
, option [] ["package-env", "env"]
"Set the environment file that may be modified."
cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf })
(reqArg "ENV" (succeedReadE Flag) flagToList)
, option [] ["overwrite-policy"]
"How to handle already existing symlinks."