Commit 5b1eca08 authored by Duncan Coutts's avatar Duncan Coutts

elaborate impl of findProjectRoot

Take an extra arg to control where to start searching, not just process
current directory. This is mainly to make it easier to test without
having to mutate the cwd but is potentially useful generally for
cwd-independence.

Return more detailed info: not just the directory but return if it's an
implicit or an explict project root with a cabal.project file. In the
latter case also return the cabal.project file since its name can be
overridden. Then also adjust defaultDistDirLayout to take this more
detailed ProjectRoot type, thus avoiding having to duplicate the logic
about the location of the cabal.project file.

Change the behaviour so that if an explicit cabal.project file name is
given and it is not found then fail, rather than falling back to an
implicit project root style. This would seem to make most sense: if the
user specifies an explict cabal.project file then it'd be odd if we
silently ignore that if the user misspells it or something. The implicit
root default is really for the really simple case, not when users are
explicitly specifying stuff.

Also add a couple simple tests for findProjectRoot.
parent 2b26e75b
......@@ -10,6 +10,7 @@ module Distribution.Client.DistDirLayout (
DistDirLayout(..),
DistDirParams(..),
defaultDistDirLayout,
ProjectRoot(..),
-- * 'CabalDirLayout'
CabalDirLayout(..),
......@@ -119,24 +120,41 @@ data CabalDirLayout = CabalDirLayout {
cabalWorldFile :: FilePath
}
-- | Information about the root directory of the project.
--
-- It can either be an implict project root in the current dir if no
-- @cabal.project@ file is found, or an explicit root if the file is found.
--
data ProjectRoot =
-- | -- ^ An implict project root. It contains the absolute project
-- root dir.
ProjectRootImplicit FilePath
-- | -- ^ An explicit project root. It contains the absolute project
-- root dir and the absolute @cabal.project@ file (or explicit override)
| ProjectRootExplicit FilePath FilePath
-- | 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.
--
defaultDistDirLayout :: FilePath -- ^ the project root directory (absolute)
defaultDistDirLayout :: ProjectRoot -- ^ the project root
-> Maybe FilePath -- ^ the @dist@ directory or default
-- (absolute or relative to the root)
-> Maybe FilePath -- ^ the @cabal.project@ file or default
-- (absolute or relative to the root)
-> DistDirLayout
defaultDistDirLayout projectRootDir mdistDirectory mprojectFile =
defaultDistDirLayout projectRoot mdistDirectory =
DistDirLayout {..}
where
(projectRootDir, projectFile) = case projectRoot of
ProjectRootImplicit dir -> (dir, dir </> "cabal.project")
ProjectRootExplicit dir file -> (dir, file)
distProjectRootDirectory = projectRootDir
distProjectFile ext = projectRootDir
</> fromMaybe "cabal.project" mprojectFile <.> ext
distProjectFile ext = projectFile <.> ext
distDirectory = projectRootDir </> fromMaybe "dist-newstyle" mdistDirectory
distDirectory = distProjectRootDirectory
</> fromMaybe "dist-newstyle" mdistDirectory
--TODO: switch to just dist at some point, or some other new name
distBuildRootDirectory = distDirectory </> "build"
......
......@@ -54,6 +54,7 @@ import Distribution.PackageDescription.Parse
import qualified Data.Set as S
import System.Directory (getCurrentDirectory)
import System.Exit (exitFailure)
import Control.Exception (throwIO)
-- | Entry point for the 'outdated' command.
outdated :: Verbosity -> OutdatedFlags -> RepoContext
......@@ -126,8 +127,9 @@ depsFromFreezeFile verbosity = do
-- | Read the list of dependencies from the new-style freeze file.
depsFromNewFreezeFile :: Verbosity -> IO [Dependency]
depsFromNewFreezeFile verbosity = do
projectRootDir <- findProjectRoot {- TODO: Support '--project-file' -} mempty
let distDirLayout = defaultDistDirLayout projectRootDir Nothing Nothing
projectRoot <- either throwIO return =<<
findProjectRoot Nothing {- TODO: Support '--project-file': -} Nothing
let distDirLayout = defaultDistDirLayout projectRoot {- TODO: Support dist dir override -} Nothing
projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $
readProjectLocalFreezeConfig verbosity distDirLayout
let ucnstrs = map fst . projectConfigConstraints . projectConfigShared
......
......@@ -13,8 +13,12 @@ module Distribution.Client.ProjectConfig (
MapLast(..),
MapMappend(..),
-- * Project config files
-- * Project root
findProjectRoot,
ProjectRoot(..),
BadProjectRoot(..),
-- * Project config files
readProjectConfig,
readProjectLocalFreezeConfig,
writeProjectLocalExtraConfig,
......@@ -55,7 +59,7 @@ import Distribution.Client.Glob
import Distribution.Client.Types
import Distribution.Client.DistDirLayout
( DistDirLayout(..), CabalDirLayout(..) )
( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) )
import Distribution.Client.GlobalFlags
( RepoContext(..), withRepoContext' )
import Distribution.Client.BuildReports.Types
......@@ -348,38 +352,44 @@ resolveBuildTimeSettings verbosity
-- parent directories. If no project file is found then the current dir is the
-- project root (and the project will use an implicit config).
--
-- Throws 'BadProjectRoot'.
--
findProjectRoot :: Maybe FilePath -> IO FilePath
findProjectRoot (Just projectFile)
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 return (takeDirectory projectFile)
else throwIO (BadProjectRootExplicitFile projectFile)
findProjectRoot mprojectFile = do
let projectFileName = fromMaybe "cabal.project" mprojectFile
curdir <- getCurrentDirectory
homedir <- getHomeDirectory
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
homedir <- getHomeDirectory
probe startdir homedir
where
projectFileName = fromMaybe "cabal.project" mprojectFile
-- Search upwards. If we get to the users home dir or the filesystem root,
-- then use the current dir
let probe dir | isDrive dir || dir == homedir
= return curdir -- implicit project root
probe dir = do
probe startdir homedir = go startdir
where
go dir | isDrive dir || dir == homedir =
case mprojectFile of
Nothing -> return (Right (ProjectRootImplicit startdir))
Just file -> return (Left (BadProjectRootExplicitFile file))
go dir = do
exists <- doesFileExist (dir </> projectFileName)
if exists
then return dir -- explicit project root
else probe (takeDirectory dir)
then return (Right (ProjectRootExplicit dir projectFileName))
else go (takeDirectory dir)
probe curdir
--TODO: [nice to have] add compat support for old style sandboxes
-- | Exception thrown by 'findProjectRoot'.
-- | Errors returned by 'findProjectRoot'.
--
data BadProjectRoot = BadProjectRootExplicitFile FilePath
#if MIN_VERSION_base(4,8,0)
......
......@@ -122,7 +122,7 @@ import Data.Map (Map)
import Data.List
import Data.Maybe
import Data.Either
import Control.Exception (Exception(..))
import Control.Exception (Exception(..), throwIO)
import System.Exit (ExitCode(..), exitFailure)
import qualified System.Process.Internals as Process (translate)
#ifdef MIN_VERSION_unix
......@@ -147,12 +147,12 @@ establishProjectBaseContext :: Verbosity
establishProjectBaseContext verbosity cliConfig = do
cabalDir <- defaultCabalDir
projectRootDir <- findProjectRoot mprojectFile
projectRoot <- either throwIO return =<<
findProjectRoot Nothing mprojectFile
let cabalDirLayout = defaultCabalDirLayout cabalDir
distDirLayout = defaultDistDirLayout projectRootDir
distDirLayout = defaultDistDirLayout projectRoot
mdistDirectory
mprojectFile
(projectConfig, localPackages) <-
rebuildProjectConfig verbosity
......
......@@ -48,10 +48,12 @@ tests config =
--TODO: tests for:
-- * normal success
-- * dry-run tests with changes
[ testGroup "Exceptions during discovery and planning" $
[ testCase "no package" (testExceptionInFindingPackage config)
, testCase "no package2" (testExceptionInFindingPackage2 config)
, testCase "proj conf1" (testExceptionInProjectConfig config)
[ testGroup "Discovery and planning" $
[ testCase "find root" testFindProjectRoot
, testCase "find root fail" testExceptionFindProjectRoot
, testCase "no package" (testExceptionInFindingPackage config)
, testCase "no package2" (testExceptionInFindingPackage2 config)
, testCase "proj conf1" (testExceptionInProjectConfig config)
]
, testGroup "Exceptions during building (local inplace)" $
[ testCase "configure" (testExceptionInConfigureStep config)
......@@ -70,6 +72,23 @@ tests config =
]
]
testFindProjectRoot :: Assertion
testFindProjectRoot = do
Left (BadProjectRootExplicitFile file) <- findProjectRoot (Just testdir)
(Just testfile)
file @?= testfile
where
testdir = basedir </> "exception/no-pkg2"
testfile = "bklNI8O1OpOUuDu3F4Ij4nv3oAqN"
testExceptionFindProjectRoot :: Assertion
testExceptionFindProjectRoot = do
Right (ProjectRootExplicit dir _) <- findProjectRoot (Just testdir) Nothing
cwd <- getCurrentDirectory
dir @?= cwd </> testdir
where
testdir = basedir </> "exception/no-pkg2"
testExceptionInFindingPackage :: ProjectConfig -> Assertion
testExceptionInFindingPackage config = do
BadPackageLocations _ locs <- expectException "BadPackageLocations" $
......@@ -247,9 +266,13 @@ planProject testdir cliConfig = do
cabalDir <- defaultCabalDir
let cabalDirLayout = defaultCabalDirLayout cabalDir
projectRootDir <- canonicalizePath ("tests" </> "IntegrationTests2"
</> testdir)
let distDirLayout = defaultDistDirLayout projectRootDir Nothing Nothing
projectRootDir <- canonicalizePath (basedir </> testdir)
isexplict <- doesFileExist (projectRootDir </> "cabal.project")
let projectRoot
| isexplict = ProjectRootExplicit projectRootDir
(projectRootDir </> "cabal.project")
| otherwise = ProjectRootImplicit projectRootDir
distDirLayout = defaultDistDirLayout projectRoot Nothing
-- Clear state between test runs. The state remains if the previous run
-- ended in an exception (as we leave the files to help with debugging).
......@@ -322,8 +345,8 @@ cleanProject testdir = do
alreadyExists <- doesDirectoryExist distDir
when alreadyExists $ removeDirectoryRecursive distDir
where
projectRootDir = "tests" </> "IntegrationTests2" </> testdir
distDirLayout = defaultDistDirLayout projectRootDir Nothing Nothing
projectRoot = ProjectRootImplicit (basedir </> testdir)
distDirLayout = defaultDistDirLayout projectRoot Nothing
distDir = distDirectory distDirLayout
......
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