Merge pull request #8454 from cydparser/project-root

Add --project-dir flag

cabal-install/src/Distribution/Client/CmdClean.hs

@@ -39,6 +39,7 @@ data CleanFlags = CleanFlags
     { cleanSaveConfig  :: Flag Bool
     , cleanVerbosity   :: Flag Verbosity
     , cleanDistDir     :: Flag FilePath
+    , cleanProjectDir  :: Flag FilePath
     , cleanProjectFile :: Flag FilePath
     } deriving (Eq)
 
@@ -47,6 +48,7 @@ defaultCleanFlags = CleanFlags
     { cleanSaveConfig  = toFlag False
     , cleanVerbosity   = toFlag normal
     , cleanDistDir     = NoFlag
+    , cleanProjectDir  = mempty
     , cleanProjectFile = mempty
     }
 
@@ -68,9 +70,12 @@ cleanCommand = CommandUI
         , optionDistPref
             cleanDistDir (\dd flags -> flags { cleanDistDir = dd })
             showOrParseArgs
+        , option [] ["project-dir"]
+            "Set the path of the project directory"
+            cleanProjectDir (\path flags -> flags {cleanProjectDir = path})
+            (reqArg "DIR" (succeedReadE Flag) flagToList)
         , option [] ["project-file"]
-            ("Set the name of the cabal.project file"
-             ++ " to search for in parent directories")
+            "Set the path of the cabal.project file (relative to the project directory when relative)"
             cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf})
             (reqArg "FILE" (succeedReadE Flag) flagToList)
         , option ['s'] ["save-config"]
@@ -85,6 +90,7 @@ cleanAction CleanFlags{..} extraArgs _ = do
     let verbosity      = fromFlagOrDefault normal cleanVerbosity
         saveConfig     = fromFlagOrDefault False  cleanSaveConfig
         mdistDirectory = flagToMaybe cleanDistDir
+        mprojectDir    = flagToMaybe cleanProjectDir
         mprojectFile   = flagToMaybe cleanProjectFile
 
     -- TODO interpret extraArgs as targets and clean those targets only (issue #7506)
@@ -95,7 +101,7 @@ cleanAction CleanFlags{..} extraArgs _ = do
         die' verbosity $ "'clean' extra arguments should be script files: "
                          ++ unwords notScripts
 
-    projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile
+    projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
 
     let distLayout = defaultDistDirLayout projectRoot mdistDirectory
 

cabal-install/src/Distribution/Client/CmdOutdated.hs

@@ -216,14 +216,14 @@ outdatedOptions _showOrParseArgs =
 
 -- | Entry point for the 'outdated' command.
 outdatedAction :: (ProjectFlags, OutdatedFlags) -> [String] -> GlobalFlags -> IO ()
-outdatedAction (ProjectFlags{flagProjectFileName}, OutdatedFlags{..}) _targetStrings globalFlags = do
+outdatedAction (ProjectFlags{flagProjectDir, flagProjectFile}, OutdatedFlags{..}) _targetStrings globalFlags = do
   config <- loadConfigOrSandboxConfig verbosity globalFlags
   let globalFlags' = savedGlobalFlags config `mappend` globalFlags
       configFlags  = savedConfigureFlags config
   withRepoContext verbosity globalFlags' $ \repoContext -> do
-    when (not newFreezeFile && isJust mprojectFile) $
+    when (not newFreezeFile && (isJust mprojectDir || isJust mprojectFile)) $
       die' verbosity $
-        "--project-file must only be used with --v2-freeze-file."
+        "--project-dir and --project-file must only be used with --v2-freeze-file."
 
     sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
     (comp, platform, _progdb) <- configCompilerAux' configFlags
@@ -234,7 +234,7 @@ outdatedAction (ProjectFlags{flagProjectFileName}, OutdatedFlags{..}) _targetStr
                        httpTransport <- configureTransport verbosity
                          (fromNubList . globalProgPathExtra $ globalFlags)
                          (flagToMaybe . globalHttpTransport $ globalFlags)
-                       depsFromNewFreezeFile verbosity httpTransport comp platform mprojectFile
+                       depsFromNewFreezeFile verbosity httpTransport comp platform mprojectDir mprojectFile
                 else do
                   depsFromPkgDesc verbosity comp platform
     debug verbosity $ "Dependencies loaded: "
@@ -252,7 +252,8 @@ outdatedAction (ProjectFlags{flagProjectFileName}, OutdatedFlags{..}) _targetStr
                       else fromFlagOrDefault normal outdatedVerbosity
     freezeFile    = fromFlagOrDefault False outdatedFreezeFile
     newFreezeFile = fromFlagOrDefault False outdatedNewFreezeFile
-    mprojectFile  = flagToMaybe flagProjectFileName
+    mprojectDir   = flagToMaybe flagProjectDir
+    mprojectFile  = flagToMaybe flagProjectFile
     simpleOutput  = fromFlagOrDefault False outdatedSimpleOutput
     quiet         = fromFlagOrDefault False outdatedQuiet
     exitCode      = fromFlagOrDefault quiet outdatedExitCode
@@ -298,10 +299,10 @@ depsFromFreezeFile verbosity = do
   return deps
 
 -- | Read the list of dependencies from the new-style freeze file.
-depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Compiler -> Platform -> Maybe FilePath -> IO [PackageVersionConstraint]
-depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mprojectFile = do
+depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Compiler -> Platform -> Maybe FilePath -> Maybe FilePath -> IO [PackageVersionConstraint]
+depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mprojectDir mprojectFile = do
   projectRoot <- either throwIO return =<<
-                 findProjectRoot Nothing mprojectFile
+                 findProjectRoot verbosity mprojectDir mprojectFile
   let distDirLayout = defaultDistDirLayout projectRoot
                       {- TODO: Support dist dir override -} Nothing
   projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ do

cabal-install/src/Distribution/Client/Config.hs

@@ -525,7 +525,8 @@ instance Semigroup SavedConfig where
           lastNonEmpty = lastNonEmpty'   savedBenchmarkFlags
 
       combinedSavedProjectFlags = ProjectFlags
-        { flagProjectFileName = combine flagProjectFileName
+        { flagProjectDir      = combine flagProjectDir
+        , flagProjectFile     = combine flagProjectFile
         , flagIgnoreProject   = combine flagIgnoreProject
         }
         where

cabal-install/src/Distribution/Client/DistDirLayout.hs

@@ -10,7 +10,10 @@ module Distribution.Client.DistDirLayout (
     DistDirLayout(..),
     DistDirParams(..),
     defaultDistDirLayout,
+
+    -- * 'ProjectRoot'
     ProjectRoot(..),
+    defaultProjectFile,
 
     -- * 'StoreDirLayout'
     StoreDirLayout(..),
@@ -64,7 +67,7 @@ data DistDirParams = DistDirParams {
 data DistDirLayout = DistDirLayout {
 
        -- | The root directory of the project. Many other files are relative to
-       -- this location. In particular, the @cabal.project@ lives here.
+       -- this location (e.g. the @cabal.project@ file).
        --
        distProjectRootDirectory     :: FilePath,
 
@@ -156,18 +159,26 @@ data CabalDirLayout = CabalDirLayout {
 -- | Information about the root directory of the project.
 --
 -- It can either be an implicit project root in the current dir if no
--- @cabal.project@ file is found, or an explicit root if the file is found.
+-- @cabal.project@ file is found, or an explicit root if either
+-- the file is found or the project root directory was specicied.
 --
 data ProjectRoot =
-       -- | -- ^ An implicit project root. It contains the absolute project
+       -- | An implicit project root. It contains the absolute project
        -- root dir.
        ProjectRootImplicit FilePath
 
-       -- | -- ^ An explicit project root. It contains the absolute project
+       -- | An explicit project root. It contains the absolute project
        -- root dir and the relative @cabal.project@ file (or explicit override)
      | ProjectRootExplicit FilePath FilePath
+
+       -- | An explicit, absolute project root dir and an explicit, absolute
+       -- @cabal.project@ file.
+     | ProjectRootExplicitAbsolute FilePath FilePath
   deriving (Eq, Show)
 
+defaultProjectFile :: FilePath
+defaultProjectFile = "cabal.project"
+
 -- | Make the default 'DistDirLayout' based on the project root dir and
 -- optional overrides for the location of the @dist@ directory and the
 -- @cabal.project@ file.
@@ -180,8 +191,9 @@ defaultDistDirLayout projectRoot mdistDirectory =
     DistDirLayout {..}
   where
     (projectRootDir, projectFile) = case projectRoot of
-      ProjectRootImplicit dir      -> (dir, dir </> "cabal.project")
-      ProjectRootExplicit dir file -> (dir, dir </> file)
+      ProjectRootImplicit dir              -> (dir, dir </> defaultProjectFile)
+      ProjectRootExplicit dir file         -> (dir, dir </> file)
+      ProjectRootExplicitAbsolute dir file -> (dir, file)
 
     distProjectRootDirectory :: FilePath
     distProjectRootDirectory = projectRootDir

cabal-install/src/Distribution/Client/ProjectConfig.hs

@@ -22,7 +22,7 @@ module Distribution.Client.ProjectConfig (
     -- * Project root
     findProjectRoot,
     ProjectRoot(..),
-    BadProjectRoot(..),
+    BadProjectRoot,
 
     -- * Project config files
     readProjectConfig,
@@ -73,7 +73,7 @@ import Distribution.Client.VCS
 
 import Distribution.Client.Types
 import Distribution.Client.DistDirLayout
-         ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) )
+         ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..), defaultProjectFile )
 import Distribution.Client.GlobalFlags
          ( RepoContext(..), withRepoContext' )
 import Distribution.Client.BuildReports.Types
@@ -400,30 +400,61 @@ resolveBuildTimeSettings verbosity
 
 -- | Find the root of this project.
 --
--- Searches for an explicit @cabal.project@ file, in the current directory or
--- parent directories. If no project file is found then the current dir is the
--- project root (and the project will use an implicit config).
+-- The project directory will be one of the following:
+--   1. @mprojectDir@ when present
+--   2. The first directory containing @mprojectFile@/@cabal.project@, starting from the current directory
+--      and recursively checking parent directories
+--   3. The current directory
 --
-findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory
-                -> Maybe FilePath -- ^ @cabal.project@ file name override
-                -> IO (Either BadProjectRoot ProjectRoot)
-findProjectRoot _ (Just projectFile)
-  | isAbsolute projectFile = do
-    exists <- doesFileExist projectFile
-    if exists
-      then do projectFile' <- canonicalizePath projectFile
-              let projectRoot = ProjectRootExplicit (takeDirectory projectFile')
-                                                    (takeFileName projectFile')
-              return (Right projectRoot)
-      else return (Left (BadProjectRootExplicitFile projectFile))
-
-findProjectRoot mstartdir mprojectFile = do
-    startdir <- maybe getCurrentDirectory canonicalizePath mstartdir
+findProjectRoot
+  :: Verbosity
+  -> Maybe FilePath -- ^ Explicit project directory
+  -> Maybe FilePath -- ^ Explicit project file
+  -> IO (Either BadProjectRoot ProjectRoot)
+findProjectRoot verbosity mprojectDir mprojectFile = do
+  case mprojectDir of
+    Nothing
+      | Just file <- mprojectFile, isAbsolute file -> do
+          warn verbosity $
+            "Specifying an absolute path to the project file is deprecated."
+            <> " Use --project-dir to set the project's directory."
+
+          doesFileExist file >>= \case
+            False -> left (BadProjectRootExplicitFile file)
+            True  -> uncurry projectRoot =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file
+
+      | otherwise -> probeProjectRoot mprojectFile
+
+    Just dir -> doesDirectoryExist dir >>= \case
+      False -> left (BadProjectRootDir dir)
+      True  -> do
+        projectDir <- canonicalizePath dir
+
+        case mprojectFile of
+          Nothing -> pure $ Right (ProjectRootExplicit projectDir defaultProjectFile)
+
+          Just projectFile
+            | isAbsolute projectFile -> doesFileExist projectFile >>= \case
+                False -> left (BadProjectRootAbsoluteFile projectFile)
+                True  -> Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile
+
+            | otherwise -> doesFileExist (projectDir </> projectFile) >>= \case
+                False -> left (BadProjectRootDirFile dir projectFile)
+                True  -> projectRoot projectDir projectFile
+  where
+    left = pure . Left
+
+    projectRoot projectDir projectFile =
+      pure $ Right (ProjectRootExplicit projectDir projectFile)
+
+probeProjectRoot :: Maybe FilePath -> IO (Either BadProjectRoot ProjectRoot)
+probeProjectRoot mprojectFile = do
+    startdir <- getCurrentDirectory
     homedir  <- getHomeDirectory
     probe startdir homedir
   where
     projectFileName :: String
-    projectFileName = fromMaybe "cabal.project" mprojectFile
+    projectFileName = fromMaybe defaultProjectFile mprojectFile
 
     -- Search upwards. If we get to the users home dir or the filesystem root,
     -- then use the current dir
@@ -443,7 +474,11 @@ findProjectRoot mstartdir mprojectFile = do
 
 -- | Errors returned by 'findProjectRoot'.
 --
-data BadProjectRoot = BadProjectRootExplicitFile FilePath
+data BadProjectRoot
+  = BadProjectRootExplicitFile FilePath
+  | BadProjectRootDir FilePath
+  | BadProjectRootAbsoluteFile FilePath
+  | BadProjectRootDirFile FilePath FilePath
 #if MIN_VERSION_base(4,8,0)
   deriving (Show, Typeable)
 #else
@@ -459,9 +494,19 @@ instance Exception BadProjectRoot where
 #endif
 
 renderBadProjectRoot :: BadProjectRoot -> String
-renderBadProjectRoot (BadProjectRootExplicitFile projectFile) =
+renderBadProjectRoot = \case
+  BadProjectRootExplicitFile projectFile ->
     "The given project file '" ++ projectFile ++ "' does not exist."
 
+  BadProjectRootDir dir ->
+    "The given project directory '" <> dir <> "' does not exist."
+
+  BadProjectRootAbsoluteFile file ->
+    "The given project file '" <> file <> "' does not exist."
+
+  BadProjectRootDirFile dir file ->
+    "The given project directory/file combination '" <> dir </> file <> "' does not exist."
+
 withProjectOrGlobalConfig
     :: Verbosity                  -- ^ verbosity
     -> Flag Bool                  -- ^ whether to ignore local project (--ignore-project flag)
@@ -484,8 +529,7 @@ withProjectOrGlobalConfig'
 withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do
   globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
 
-  let
-    res' = catch with
+  catch with
       $ \case
         (BadPackageLocations prov locs)
           | prov == Set.singleton Implicit
@@ -496,11 +540,6 @@ withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do
             without globalConfig
         err -> throwIO err
 
-  catch res'
-    $ \case
-      (BadProjectRootExplicitFile "") -> without globalConfig
-      err -> throwIO err
-
 -- | Read all the config relevant for a project. This includes the project
 -- file if any, plus other global config.
 --

cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs

@@ -540,7 +540,8 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags
     } = installFlags
 
     ProjectFlags
-        { flagProjectFileName = projectConfigProjectFile
+        { flagProjectDir      = projectConfigProjectDir
+        , flagProjectFile     = projectConfigProjectFile
         , flagIgnoreProject   = projectConfigIgnoreProject
         } = projectFlags
 
@@ -801,7 +802,8 @@ convertToLegacySharedConfig
     }
 
     projectFlags = ProjectFlags
-        { flagProjectFileName = projectConfigProjectFile
+        { flagProjectDir      = projectConfigProjectDir
+        , flagProjectFile     = projectConfigProjectFile
         , flagIgnoreProject   = projectConfigIgnoreProject
         }
 

cabal-install/src/Distribution/Client/ProjectConfig/Types.hs

@@ -162,6 +162,7 @@ data ProjectConfigShared
    = ProjectConfigShared {
        projectConfigDistDir           :: Flag FilePath,
        projectConfigConfigFile        :: Flag FilePath,
+       projectConfigProjectDir        :: Flag FilePath,
        projectConfigProjectFile       :: Flag FilePath,
        projectConfigIgnoreProject     :: Flag Bool,
        projectConfigHcFlavor          :: Flag CompilerFlavor,