diff --git a/cabal-install/Distribution/Client/CmdBench.hs b/cabal-install/Distribution/Client/CmdBench.hs index 0fbfd475f35d8cf0029b3f203ca39e856e6189cf..c07f5be3890f9742f1a2fbc5b9f017e49214b03a 100644 --- a/cabal-install/Distribution/Client/CmdBench.hs +++ b/cabal-install/Distribution/Client/CmdBench.hs @@ -117,7 +117,9 @@ benchAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs index 7ca536953baae71683656337b7fa9d51b794a890..cb1858837a4b29e656c47562aba99ff9049764b8 100644 --- a/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal-install/Distribution/Client/CmdBuild.hs @@ -157,7 +157,9 @@ buildAction verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal-install/Distribution/Client/CmdConfigure.hs b/cabal-install/Distribution/Client/CmdConfigure.hs index 87b7b2b280dcf2be9affda7b0d2c31f0ee38adcc..7953167cdcbfd12ca1fb19c8841bfcd049523058 100644 --- a/cabal-install/Distribution/Client/CmdConfigure.hs +++ b/cabal-install/Distribution/Client/CmdConfigure.hs @@ -121,5 +121,7 @@ configureAction (configFlags, configExFlags, installFlags, haddockFlags, testFla verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags diff --git a/cabal-install/Distribution/Client/CmdExec.hs b/cabal-install/Distribution/Client/CmdExec.hs index 76fc521ec0ef2d35d8b28cd1ea1f48b52ec1173f..596337250faffb16812aa6a3e6e11a04421504f2 100644 --- a/cabal-install/Distribution/Client/CmdExec.hs +++ b/cabal-install/Distribution/Client/CmdExec.hs @@ -194,7 +194,9 @@ execAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags withOverrides env args program = program { programOverrideEnv = programOverrideEnv program ++ env , programDefaultArgs = programDefaultArgs program ++ args} diff --git a/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal-install/Distribution/Client/CmdFreeze.hs index 1eb7cc398cdedf49aba21d79888b05e78d8fc5ac..f8328dd70defcd1ff25172e33f81fd1fbdb35dd8 100644 --- a/cabal-install/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/Distribution/Client/CmdFreeze.hs @@ -130,7 +130,9 @@ freezeAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags diff --git a/cabal-install/Distribution/Client/CmdHaddock.hs b/cabal-install/Distribution/Client/CmdHaddock.hs index 2e56f6fd9f0a99a58da7357e75510d8a0435470e..2670cda5e0460a84089249422297ad593fae3706 100644 --- a/cabal-install/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/Distribution/Client/CmdHaddock.hs @@ -111,7 +111,9 @@ haddockAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags -- | This defines what a 'TargetSelector' means for the @haddock@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs index fc23d4347a704aaf5065dfefb579261ed3564666..0b394011a23e6787e3d72bf06fe0d5fb9264ca34 100644 --- a/cabal-install/Distribution/Client/CmdInstall.hs +++ b/cabal-install/Distribution/Client/CmdInstall.hs @@ -20,11 +20,15 @@ module Distribution.Client.CmdInstall ( import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Compat.Directory + ( doesPathExist ) import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.CmdSdist +import Distribution.Client.CmdInstall.ClientInstallFlags + import Distribution.Client.Setup ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) , configureExOptions, haddockOptions, installOptions, testOptions @@ -51,7 +55,7 @@ import Distribution.Simple.Program.Db import Distribution.Simple.Program.Find ( ProgramSearchPathEntry(..) ) import Distribution.Client.Config - ( getCabalDir ) + ( getCabalDir, loadConfig, SavedConfig(..) ) import qualified Distribution.Simple.PackageIndex as PI import Distribution.Solver.Types.PackageIndex ( lookupPackageName, searchByName ) @@ -78,15 +82,11 @@ import Distribution.Client.RebuildMonad import Distribution.Client.InstallSymlink ( OverwritePolicy(..), symlinkBinary ) import Distribution.Simple.Setup - ( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe - , trueArg, flagToList, toFlag ) + ( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) -import Distribution.ReadE - ( ReadE(..), succeedReadE ) import Distribution.Simple.Command - ( CommandUI(..), ShowOrParseArgs(..), OptionField(..) - , option, usageAlternatives, reqArg ) + ( CommandUI(..), OptionField(..), usageAlternatives ) import Distribution.Simple.Configure ( configCompilerEx ) import Distribution.Simple.Compiler @@ -128,52 +128,14 @@ import Distribution.Utils.NubList ( fromNubList ) import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing - , getTemporaryDirectory, makeAbsolute, doesDirectoryExist ) + , getTemporaryDirectory, makeAbsolute, doesDirectoryExist + , removeFile, removeDirectory, copyFile ) import System.FilePath ( (), 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 - , HaddockFlags, TestFlags, NewInstallFlags + , HaddockFlags, TestFlags, ClientInstallFlags ) installCommand = CommandUI { commandName = "v2-install" @@ -182,8 +144,8 @@ installCommand = CommandUI "v2-install" [ "[TARGETS] [FLAGS]" ] , commandDescription = Just $ \_ -> wrapText $ "Installs one or more packages. This is done by installing them " - ++ "in the store and symlinking the executables in the directory " - ++ "specified by the --symlink-bindir flag (`~/.cabal/bin/` by default). " + ++ "in the store and symlinking/copying the executables in the directory " + ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). " ++ "If you want the installed executables to be available globally, " ++ "make sure that the PATH environment variable contains that directory. " ++ "\n\n" @@ -211,9 +173,10 @@ installCommand = CommandUI . optionName) $ configureOptions showOrParseArgs) ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) ++ liftOptions get3 set3 - -- hide "target-package-db" flag from the + -- hide "target-package-db" and "symlink-bindir" flags from the -- install options. - (filter ((`notElem` ["target-package-db"]) + -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags + (filter ((`notElem` ["target-package-db", "symlink-bindir"]) . optionName) $ installOptions showOrParseArgs) ++ liftOptions get4 set4 @@ -223,8 +186,8 @@ installCommand = CommandUI . optionName) $ haddockOptions showOrParseArgs) ++ liftOptions get5 set5 (testOptions showOrParseArgs) - ++ liftOptions get6 set6 (newInstallOptions showOrParseArgs) - , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, defaultNewInstallFlags) + ++ liftOptions get6 set6 (clientInstallOptions showOrParseArgs) + , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, defaultClientInstallFlags) } where get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) @@ -241,7 +204,7 @@ installCommand = CommandUI -- install command, except that now conflicts between separate runs of the -- command are impossible thanks to the store. -- 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 -- estra packages and using a temporary dist directory. -- * libraries @@ -252,9 +215,9 @@ installCommand = CommandUI -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, NewInstallFlags) +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ClientInstallFlags) -> [String] -> GlobalFlags -> IO () -installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, newInstallFlags) +installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, clientInstallFlags') targetStrings globalFlags = do -- We never try to build tests/benchmarks for remote packages. -- So we set them as disabled by default and error if they are explicitly @@ -266,6 +229,14 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " ++ "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 withProject = do let verbosity' = lessVerbose verbosity @@ -485,7 +456,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags GhcEnvFilePackageId _ -> True _ -> False - envFile <- case flagToMaybe (ninstEnvironmentPath newInstallFlags) of + envFile <- case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of Just spec -- Is spec a bare word without any "pathy" content, then it refers to -- a named global environment. @@ -571,52 +542,53 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags -- First, figure out if / what parts we want to install: let dryRun = buildSettingDryRun $ buildSettings baseCtx - installLibs = fromFlagOrDefault False (ninstInstallLibs newInstallFlags) + installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) -- Then, install! when (not dryRun) $ if installLibs then installLibraries verbosity buildCtx compiler packageDbs progDb envFile envEntries' - else installExes verbosity baseCtx buildCtx compiler newInstallFlags + else installExes verbosity baseCtx buildCtx compiler clientInstallFlags where configFlags' = disableTestsBenchsByDefault configFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags') cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags' configExFlags - installFlags haddockFlags testFlags + installFlags clientInstallFlags' + haddockFlags testFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) --- | Install any built exe by symlinking it +-- | Install any built exe by symlinking/copying it installExes :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Compiler - -> NewInstallFlags + -> ClientInstallFlags -> 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") . storePackageDirectory (cabalStoreDirLayout $ cabalDirLayout baseCtx) (compilerId compiler) - symlinkBindirUnknown = - "symlink-bindir is not defined. Set it in your cabal config file " - ++ "or use --symlink-bindir=" - symlinkBindir <- fromFlagOrDefault (die' verbosity symlinkBindirUnknown) - $ fmap makeAbsolute - $ projectConfigSymlinkBinDir - $ projectConfigBuildOnly - $ projectConfig baseCtx - createDirectoryIfMissingVerbose verbosity False symlinkBindir + installdirUnknown = + "installdir is not defined. Set it in your cabal config file " + ++ "or use --installdir=" + installdir <- fromFlagOrDefault (die' verbosity installdirUnknown) + $ pure <$> cinstInstalldir clientInstallFlags + createDirectoryIfMissingVerbose verbosity False installdir warnIfNoExes verbosity buildCtx let - doSymlink = symlinkBuiltPackage + doInstall = installPackageExes verbosity overwritePolicy - mkPkgBinDir symlinkBindir - in traverse_ doSymlink $ Map.toList $ targetsMap buildCtx + mkPkgBinDir installdir installMethod + in traverse_ doInstall $ Map.toList $ targetsMap buildCtx where overwritePolicy = fromFlagOrDefault NeverOverwrite - $ ninstOverwritePolicy newInstallFlags + $ cinstOverwritePolicy clientInstallFlags + installMethod = fromFlagOrDefault InstallMethodSymlink + $ cinstInstallMethod clientInstallFlags -- | Install any built library by adding it to the default ghc environment installLibraries :: Verbosity @@ -700,49 +672,78 @@ disableTestsBenchsByDefault configFlags = configFlags { configTests = Flag False <> configTests configFlags , configBenchmarks = Flag False <> configBenchmarks configFlags } --- | Symlink every exe from a package from the store to a given location -symlinkBuiltPackage :: Verbosity - -> OverwritePolicy -- ^ Whether to overwrite existing files - -> (UnitId -> FilePath) -- ^ A function to get an UnitId's - -- store directory - -> FilePath -- ^ Where to put the symlink - -> ( UnitId - , [(ComponentTarget, [TargetSelector])] ) - -> IO () -symlinkBuiltPackage verbosity overwritePolicy - mkSourceBinDir destDir - (pkg, components) = - traverse_ symlinkAndWarn exes +-- | Symlink/copy every exe from a package from the store to a given location +installPackageExes :: Verbosity + -> OverwritePolicy -- ^ Whether to overwrite existing files + -> (UnitId -> FilePath) -- ^ A function to get an UnitId's + -- store directory + -> FilePath + -> InstallMethod + -> ( UnitId + , [(ComponentTarget, [TargetSelector])] ) + -> IO () +installPackageExes verbosity overwritePolicy + mkSourceBinDir + installdir installMethod + (pkg, components) = + traverse_ installAndWarn exes where exes = catMaybes $ (exeMaybe . fst) <$> components exeMaybe (ComponentTarget (CExeName exe) _) = Just exe exeMaybe _ = Nothing - symlinkAndWarn exe = do - success <- symlinkBuiltExe + installAndWarn exe = do + success <- installBuiltExe verbosity overwritePolicy - (mkSourceBinDir pkg) destDir exe + (mkSourceBinDir pkg) exe + installdir installMethod let errorMessage = case overwritePolicy of NeverOverwrite -> - "Path '" <> (destDir prettyShow exe) <> "' already exists. " + "Path '" <> (installdir prettyShow exe) <> "' already exists. " <> "Use --overwrite-policy=always to overwrite." -- This shouldn't even be possible, but we keep it in case - -- symlinking logic changes - AlwaysOverwrite -> "Symlinking '" <> prettyShow exe <> "' failed." + -- symlinking/copying logic changes + AlwaysOverwrite -> case installMethod of + InstallMethodSymlink -> "Symlinking" + InstallMethodCopy -> "Copying" + <> " '" <> prettyShow exe <> "' failed." unless success $ die' verbosity errorMessage --- | Symlink a specific exe. -symlinkBuiltExe :: Verbosity -> OverwritePolicy - -> FilePath -> FilePath +-- | Install a specific exe. +installBuiltExe :: Verbosity -> OverwritePolicy + -> FilePath -> UnqualComponentName + -> FilePath + -> InstallMethod -> IO Bool -symlinkBuiltExe verbosity overwritePolicy sourceDir destDir exe = do +installBuiltExe verbosity overwritePolicy + sourceDir exe + installdir InstallMethodSymlink = do notice verbosity $ "Symlinking '" <> prettyShow exe <> "'" symlinkBinary overwritePolicy - destDir + installdir sourceDir 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. entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] diff --git a/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs new file mode 100644 index 0000000000000000000000000000000000000000..a139d74401eab08966f269dfcb04fb0fc753ab4f --- /dev/null +++ b/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -0,0 +1,106 @@ +{-# 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." + cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) + $ reqArg + "always|never" + readOverwritePolicyFlag + showOverwritePolicyFlag + , option [] ["install-method"] + "How to install the executables." + cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v }) + $ reqArg + "copy|symlink" + readInstallMethodFlag + showInstallMethodFlag + , option [] ["installdir"] + "Where to install (by symlinking or copying) the executables in." + cinstInstalldir (\v flags -> flags { cinstInstalldir = v }) + $ reqArg "DIR" (succeedReadE Flag) flagToList + ] + +readOverwritePolicyFlag :: ReadE (Flag OverwritePolicy) +readOverwritePolicyFlag = ReadE $ \case + "always" -> Right $ Flag AlwaysOverwrite + "never" -> Right $ Flag NeverOverwrite + policy -> Left $ "'" <> policy <> "' isn't a valid overwrite policy" + +showOverwritePolicyFlag :: Flag OverwritePolicy -> [String] +showOverwritePolicyFlag (Flag AlwaysOverwrite) = ["always"] +showOverwritePolicyFlag (Flag NeverOverwrite) = ["never"] +showOverwritePolicyFlag NoFlag = [] + +readInstallMethodFlag :: ReadE (Flag InstallMethod) +readInstallMethodFlag = ReadE $ \case + "copy" -> Right $ Flag InstallMethodCopy + "symlink" -> Right $ Flag InstallMethodSymlink + method -> Left $ "'" <> method <> "' isn't a valid install-method" + +showInstallMethodFlag :: Flag InstallMethod -> [String] +showInstallMethodFlag (Flag InstallMethodCopy) = ["copy"] +showInstallMethodFlag (Flag InstallMethodSymlink) = ["symlink"] +showInstallMethodFlag NoFlag = [] + diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs index 9588face63055f02bf44c0cb5a0f9f530fd1eda3..f20c2207319c29ab073e8a499f4697302046afde 100644 --- a/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal-install/Distribution/Client/CmdRepl.hs @@ -303,7 +303,9 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, r verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) validatedTargets elaboratedPlan targetSelectors = do diff --git a/cabal-install/Distribution/Client/CmdRun.hs b/cabal-install/Distribution/Client/CmdRun.hs index 216b39571a02c8b86f5425ff637fe587ea8644ea..e0e0d0a0e998d2d18f9a6baf8840de2701b9b05a 100644 --- a/cabal-install/Distribution/Client/CmdRun.hs +++ b/cabal-install/Distribution/Client/CmdRun.hs @@ -295,7 +295,9 @@ runAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -- | Used by the main CLI parser as heuristic to decide whether @cabal@ was diff --git a/cabal-install/Distribution/Client/CmdTest.hs b/cabal-install/Distribution/Client/CmdTest.hs index 98783c639859bd27ed106bc6016485751a1ceef2..f03f8aa118a94e6fa3fefdd8f81dab8f839f273e 100644 --- a/cabal-install/Distribution/Client/CmdTest.hs +++ b/cabal-install/Distribution/Client/CmdTest.hs @@ -129,7 +129,9 @@ testAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags -- | This defines what a 'TargetSelector' means for the @test@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal-install/Distribution/Client/CmdUpdate.hs b/cabal-install/Distribution/Client/CmdUpdate.hs index ceef3f32ffc7fb8d94d22af6850f8d93a5a45315..fe00fb2d010296cb1dc793b6bb579a3bdb2e1eec 100644 --- a/cabal-install/Distribution/Client/CmdUpdate.hs +++ b/cabal-install/Distribution/Client/CmdUpdate.hs @@ -168,7 +168,9 @@ updateAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags + installFlags + mempty -- ClientInstallFlags, not needed here + haddockFlags testFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 8e90ffbeaf4f71d4cb730f919a22387378317970..a3ef527a1e4f2dc60053d13720239cb03852ffcb 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -65,6 +65,9 @@ import Distribution.Client.Setup , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand , showRepo, parseRepo, readRepo ) +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..), defaultClientInstallFlags + , clientInstallOptions ) import Distribution.Utils.NubList ( NubList, fromNubList, toNubList, overNubList ) @@ -158,6 +161,7 @@ data SavedConfig = SavedConfig { savedGlobalFlags :: GlobalFlags, savedInitFlags :: IT.InitFlags, savedInstallFlags :: InstallFlags, + savedClientInstallFlags :: ClientInstallFlags, savedConfigureFlags :: ConfigFlags, savedConfigureExFlags :: ConfigExFlags, savedUserInstallDirs :: InstallDirs (Flag PathTemplate), @@ -177,6 +181,7 @@ instance Semigroup SavedConfig where savedGlobalFlags = combinedSavedGlobalFlags, savedInitFlags = combinedSavedInitFlags, savedInstallFlags = combinedSavedInstallFlags, + savedClientInstallFlags = combinedSavedClientInstallFlags, savedConfigureFlags = combinedSavedConfigureFlags, savedConfigureExFlags = combinedSavedConfigureExFlags, savedUserInstallDirs = combinedSavedUserInstallDirs, @@ -332,6 +337,16 @@ instance Semigroup SavedConfig where combine = combine' savedInstallFlags lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags + combinedSavedClientInstallFlags = ClientInstallFlags { + cinstInstallLibs = combine cinstInstallLibs, + cinstEnvironmentPath = combine cinstEnvironmentPath, + cinstOverwritePolicy = combine cinstOverwritePolicy, + cinstInstallMethod = combine cinstInstallMethod, + cinstInstalldir = combine cinstInstalldir + } + where + combine = combine' savedClientInstallFlags + combinedSavedConfigureFlags = ConfigFlags { configArgs = lastNonEmpty configArgs, configPrograms_ = configPrograms_ . savedConfigureFlags $ b, @@ -532,11 +547,11 @@ baseSavedConfig = do -- initialSavedConfig :: IO SavedConfig initialSavedConfig = do - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - worldFile <- defaultWorldFile - extraPath <- defaultExtraPath - symlinkPath <- defaultSymlinkPath + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + extraPath <- defaultExtraPath + installPath <- defaultInstallPath return mempty { savedGlobalFlags = mempty { globalCacheDir = toFlag cacheDir, @@ -549,8 +564,10 @@ initialSavedConfig = do savedInstallFlags = mempty { installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], installBuildReports= toFlag AnonymousReports, - installNumJobs = toFlag Nothing, - installSymlinkBinDir = toFlag symlinkPath + installNumJobs = toFlag Nothing + }, + savedClientInstallFlags = mempty { + cinstInstalldir = toFlag installPath } } @@ -590,8 +607,8 @@ defaultExtraPath = do dir <- getCabalDir return [dir "bin"] -defaultSymlinkPath :: IO FilePath -defaultSymlinkPath = do +defaultInstallPath :: IO FilePath +defaultInstallPath = do dir <- getCabalDir return (dir "bin") @@ -811,6 +828,7 @@ commentSavedConfig = do IT.applicationDirs = Nothing }, savedInstallFlags = defaultInstallFlags, + savedClientInstallFlags= defaultClientInstallFlags, savedConfigureExFlags = defaultConfigExFlags { configAllowNewer = Just (AllowNewer mempty), configAllowOlder = Just (AllowOlder mempty) @@ -933,6 +951,10 @@ configFieldDescriptions src = (installOptions ParseArgs) ["dry-run", "only", "only-dependencies", "dependencies-only"] [] + ++ toSavedConfig liftClientInstallFlag + (clientInstallOptions ParseArgs) + [] [] + ++ toSavedConfig liftUploadFlag (commandOptions uploadCommand ParseArgs) ["verbose", "check", "documentation", "publish"] [] @@ -1040,6 +1062,10 @@ liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig liftInstallFlag = liftField savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) +liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig +liftClientInstallFlag = liftField + savedClientInstallFlags (\flags conf -> conf { savedClientInstallFlags = flags }) + liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig liftUploadFlag = liftField savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs index 88d656f06e04f35d53e4c47746eeecd1129c8c50..bff924ffd958ecae0fdef8b64ea7b4a40cf4ee99 100644 --- a/cabal-install/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/Distribution/Client/InstallSymlink.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.InstallSymlink @@ -19,6 +20,9 @@ module Distribution.Client.InstallSymlink ( #ifdef mingw32_HOST_OS +import Distribution.Compat.Binary + ( Binary ) + import Distribution.Package (PackageIdentifier) import Distribution.Types.UnqualComponentName import Distribution.Client.InstallPlan (InstallPlan) @@ -27,9 +31,12 @@ import Distribution.Client.Setup (InstallFlags) import Distribution.Simple.Setup (ConfigFlags) import Distribution.Simple.Compiler import Distribution.System +import GHC.Generics (Generic) data OverwritePolicy = NeverOverwrite | AlwaysOverwrite - deriving (Show, Eq) + deriving (Show, Eq, Generic, Bounded, Enum) + +instance Binary OverwritePolicy symlinkBinaries :: Platform -> Compiler -> OverwritePolicy @@ -47,6 +54,9 @@ symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows" #else +import Distribution.Compat.Binary + ( Binary ) + import Distribution.Client.Types ( ConfiguredPackage(..), BuildOutcomes ) import Distribution.Client.Setup @@ -93,9 +103,13 @@ import Control.Exception ( assert ) import Data.Maybe ( catMaybes ) +import GHC.Generics + ( Generic ) data OverwritePolicy = NeverOverwrite | AlwaysOverwrite - deriving (Show, Eq) + deriving (Show, Eq, Generic, Bounded, Enum) + +instance Binary OverwritePolicy -- | We would like by default to install binaries into some location that is on -- the user's PATH. For per-user installations on Unix systems that basically diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 3fd2297c868f7d7862461f5b7b7067c3dc2d4d2c..620839cb7a43a74ad45e0bdde7e21daa5bfe53d5 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -33,6 +33,10 @@ import Distribution.Client.Types import Distribution.Client.Config ( SavedConfig(..), remoteRepoFields ) +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..), defaultClientInstallFlags + , clientInstallOptions ) + import Distribution.Solver.Types.ConstraintSource import Distribution.Package @@ -137,7 +141,8 @@ data LegacySharedConfig = LegacySharedConfig { legacyGlobalFlags :: GlobalFlags, legacyConfigureShFlags :: ConfigFlags, legacyConfigureExFlags :: ConfigExFlags, - legacyInstallFlags :: InstallFlags + legacyInstallFlags :: InstallFlags, + legacyClientInstallFlags:: ClientInstallFlags } deriving Generic instance Monoid LegacySharedConfig where @@ -161,16 +166,18 @@ instance Semigroup LegacySharedConfig where -- commandLineFlagsToProjectConfig :: GlobalFlags -> ConfigFlags -> ConfigExFlags - -> InstallFlags -> HaddockFlags + -> InstallFlags -> ClientInstallFlags + -> HaddockFlags -> TestFlags -> ProjectConfig commandLineFlagsToProjectConfig globalFlags configFlags configExFlags - installFlags haddockFlags testFlags = + installFlags clientInstallFlags + haddockFlags testFlags = mempty { projectConfigBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags - installFlags haddockFlags - testFlags, + installFlags clientInstallFlags + haddockFlags testFlags, projectConfigShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags, @@ -217,6 +224,7 @@ convertLegacyGlobalConfig SavedConfig { savedGlobalFlags = globalFlags, savedInstallFlags = installFlags, + savedClientInstallFlags= clientInstallFlags, savedConfigureFlags = configFlags, savedConfigureExFlags = configExFlags, savedUserInstallDirs = _, @@ -236,6 +244,7 @@ convertLegacyGlobalConfig -- defaults in the various resolve functions in terms of the new types. configExFlags' = defaultConfigExFlags <> configExFlags installFlags' = defaultInstallFlags <> installFlags + clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags haddockFlags' = defaultHaddockFlags <> haddockFlags testFlags' = defaultTestFlags <> testFlags @@ -246,7 +255,8 @@ convertLegacyGlobalConfig configExFlags' installFlags' configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags - installFlags' haddockFlags' testFlags' + installFlags' clientInstallFlags' + haddockFlags' testFlags' -- | Convert the project config from the legacy types to the 'ProjectConfig' @@ -261,7 +271,8 @@ convertLegacyProjectConfig legacyPackagesRepo, legacyPackagesNamed, legacySharedConfig = LegacySharedConfig globalFlags configShFlags - configExFlags installSharedFlags, + configExFlags installSharedFlags + clientInstallFlags, legacyAllConfig, legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags haddockFlags testFlags, @@ -292,7 +303,8 @@ convertLegacyProjectConfig configExFlags installSharedFlags configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configShFlags - installSharedFlags haddockFlags testFlags + installSharedFlags clientInstallFlags + haddockFlags testFlags perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags perPkgTestFlags) = @@ -448,13 +460,15 @@ convertLegacyPerPackageFlags configFlags installFlags haddockFlags testFlags = -- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'. -- convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags - -> InstallFlags -> HaddockFlags - -> TestFlags + -> InstallFlags -> ClientInstallFlags + -> HaddockFlags -> TestFlags -> ProjectConfigBuildOnly convertLegacyBuildOnlyFlags globalFlags configFlags - installFlags haddockFlags _ = + installFlags clientInstallFlags + haddockFlags _ = ProjectConfigBuildOnly{..} where + projectConfigClientInstallFlags = clientInstallFlags GlobalFlags { globalCacheDir = projectConfigCacheDir, globalLogsDir = projectConfigLogsDir, @@ -528,7 +542,8 @@ convertToLegacySharedConfig legacyGlobalFlags = globalFlags, legacyConfigureShFlags = configFlags, legacyConfigureExFlags = configExFlags, - legacyInstallFlags = installFlags + legacyInstallFlags = installFlags, + legacyClientInstallFlags = projectConfigClientInstallFlags } where globalFlags = GlobalFlags { @@ -965,6 +980,12 @@ legacySharedConfigFieldDescrs = ] . commandOptionsToFields ) (installOptions ParseArgs) + ++ + ( liftFields + legacyClientInstallFlags + (\flags conf -> conf { legacyClientInstallFlags = flags }) + . commandOptionsToFields + ) (clientInstallOptions ParseArgs) where constraintSrc = ConstraintSourceProjectConfig "TODO" diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index aa218a826b39101068fd41a8a6470b811c8e5ff3..137f73dbabb901f3c7eda12047aa120be09760e1 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -33,6 +33,9 @@ import Distribution.Client.BuildReports.Types import Distribution.Client.IndexUtils.Timestamp ( IndexState ) +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags(..) ) + import Distribution.Solver.Types.Settings import Distribution.Solver.Types.ConstraintSource @@ -149,7 +152,8 @@ data ProjectConfigBuildOnly projectConfigHttpTransport :: Flag String, projectConfigIgnoreExpiry :: Flag Bool, projectConfigCacheDir :: Flag FilePath, - projectConfigLogsDir :: Flag FilePath + projectConfigLogsDir :: Flag FilePath, + projectConfigClientInstallFlags :: ClientInstallFlags } deriving (Eq, Show, Generic) diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 3a342623812ffde8096d2a871b0059d5e07413ad..ee91f54a03f7af84c13b739f70750aa38a4f8f50 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -1720,6 +1720,8 @@ data InstallFlags = InstallFlags { installLogFile :: Flag PathTemplate, installBuildReports :: Flag ReportLevel, installReportPlanningFailure :: Flag Bool, + -- Note: symlink-bindir is no longer used by v2-install and can be removed + -- when removing v1 commands installSymlinkBinDir :: Flag FilePath, installPerComponent :: Flag Bool, installOneShot :: Flag Bool, diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index cd80b7f695be32bf49cf18b1febc1f311d13d4f9..42c2851822db85379f92114d6bc2f457dd46a902 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -168,6 +168,7 @@ executable cabal Distribution.Client.CmdFreeze Distribution.Client.CmdHaddock Distribution.Client.CmdInstall + Distribution.Client.CmdInstall.ClientInstallFlags Distribution.Client.CmdRepl Distribution.Client.CmdRun Distribution.Client.CmdTest diff --git a/cabal-install/cabal-install.cabal.pp b/cabal-install/cabal-install.cabal.pp index e452bbc23a4d876cf5ebab1dabb02a5d0321f853..c4725d35b44d90b0b49b91eb115ea0c668b74827 100644 --- a/cabal-install/cabal-install.cabal.pp +++ b/cabal-install/cabal-install.cabal.pp @@ -96,6 +96,7 @@ Version: 3.0.0.0 Distribution.Client.CmdFreeze Distribution.Client.CmdHaddock Distribution.Client.CmdInstall + Distribution.Client.CmdInstall.ClientInstallFlags Distribution.Client.CmdRepl Distribution.Client.CmdRun Distribution.Client.CmdTest diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index acf4862bc7cac03ccb1b594655507c44cc2c2e6d..e9e8304a293f4888565823a3687dd5259f7e9ace 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -28,6 +28,8 @@ import Distribution.Simple.Program.Db import Distribution.Types.PackageVersionConstraint import Distribution.Client.Types +import Distribution.Client.CmdInstall.ClientInstallFlags +import Distribution.Client.InstallSymlink import Distribution.Client.Dependency.Types import Distribution.Client.BuildReports.Types import Distribution.Client.Targets @@ -349,6 +351,21 @@ arbitraryGlobLikeStr = outerTerm braces s = "{" ++ s ++ "}" +instance Arbitrary OverwritePolicy where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary InstallMethod where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary ClientInstallFlags where + arbitrary = + ClientInstallFlags + <$> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + instance Arbitrary ProjectConfigBuildOnly where arbitrary = ProjectConfigBuildOnly @@ -369,6 +386,7 @@ instance Arbitrary ProjectConfigBuildOnly where <*> arbitrary <*> (fmap getShortToken <$> arbitrary) <*> (fmap getShortToken <$> arbitrary) + <*> arbitrary where arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary @@ -388,7 +406,8 @@ instance Arbitrary ProjectConfigBuildOnly where , projectConfigHttpTransport = x13 , projectConfigIgnoreExpiry = x14 , projectConfigCacheDir = x15 - , projectConfigLogsDir = x16 } = + , projectConfigLogsDir = x16 + , projectConfigClientInstallFlags = x17 } = [ ProjectConfigBuildOnly { projectConfigVerbosity = x00' , projectConfigDryRun = x01' , projectConfigOnlyDeps = x02' @@ -405,14 +424,17 @@ instance Arbitrary ProjectConfigBuildOnly where , projectConfigHttpTransport = x13 , projectConfigIgnoreExpiry = x14' , projectConfigCacheDir = x15 - , projectConfigLogsDir = x16 } + , projectConfigLogsDir = x16 + , projectConfigClientInstallFlags = x17' } | ((x00', x01', x02', x03', x04'), (x05', x06', x07', x08', x09'), - (x10', x11', x12', x14')) + (x10', x11', x12', x14'), + ( x17' )) <- shrink ((x00, x01, x02, x03, x04), (x05, x06, x07, x08, preShrink_NumJobs x09), - (x10, x11, x12, x14)) + (x10, x11, x12, x14), + ( x17 )) ] where preShrink_NumJobs = fmap (fmap Positive)