Commit 010c71bf authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Improve classification of project package problems in a couple cases

So we get more accurate helpful error messages in those cases.
Also update a corresponding test.
parent a1a9e2e0
...@@ -671,6 +671,10 @@ findProjectPackages projectRootDir ProjectConfig{..} = do ...@@ -671,6 +671,10 @@ findProjectPackages projectRootDir ProjectConfig{..} = do
| recognisedScheme && not (null host) -> | recognisedScheme && not (null host) ->
Just (Right [ProjectPackageRemoteTarball uri]) Just (Right [ProjectPackageRemoteTarball uri])
--TODO: [required eventually] handle file: urls which do have a null
-- host. translate URI into filepath and use ProjectPackageLocalTarball
-- or keep as file url and use ProjectPackageRemoteTarball?
| not recognisedScheme && not (null host) -> | not recognisedScheme && not (null host) ->
Just (Left (BadLocUnexpectedUriScheme pkglocstr)) Just (Left (BadLocUnexpectedUriScheme pkglocstr))
...@@ -698,9 +702,11 @@ findProjectPackages projectRootDir ProjectConfig{..} = do ...@@ -698,9 +702,11 @@ findProjectPackages projectRootDir ProjectConfig{..} = do
_ -> do _ -> do
(failures, pkglocs) <- partitionEithers <$> (failures, pkglocs) <- partitionEithers <$>
mapM checkFilePackageMatch matches mapM checkFilePackageMatch matches
if null pkglocs return $! case (failures, pkglocs) of
then return (Left (BadLocGlobBadMatches pkglocstr failures)) ([failure], []) | isJust (isTrivialFilePathGlob glob)
else return (Right pkglocs) -> Left (BadPackageLocationFile failure)
(_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)
_ -> Right pkglocs
checkIsSingleFilePackage pkglocstr = do checkIsSingleFilePackage pkglocstr = do
...@@ -721,6 +727,7 @@ findProjectPackages projectRootDir ProjectConfig{..} = do ...@@ -721,6 +727,7 @@ findProjectPackages projectRootDir ProjectConfig{..} = do
-- Either way, </> does the right thing here. We return relative paths if -- Either way, </> does the right thing here. We return relative paths if
-- they were relative in the first place. -- they were relative in the first place.
let abspath = projectRootDir </> pkglocstr let abspath = projectRootDir </> pkglocstr
isFile <- liftIO $ doesFileExist abspath
isDir <- liftIO $ doesDirectoryExist abspath isDir <- liftIO $ doesDirectoryExist abspath
parentDirExists <- case takeDirectory abspath of parentDirExists <- case takeDirectory abspath of
[] -> return False [] -> return False
...@@ -741,6 +748,9 @@ findProjectPackages projectRootDir ProjectConfig{..} = do ...@@ -741,6 +748,9 @@ findProjectPackages projectRootDir ProjectConfig{..} = do
| takeExtension pkglocstr == ".cabal" | takeExtension pkglocstr == ".cabal"
-> return (Right (ProjectPackageLocalCabalFile pkglocstr)) -> return (Right (ProjectPackageLocalCabalFile pkglocstr))
| isFile
-> return (Left (BadLocUnexpectedFile pkglocstr))
| parentDirExists | parentDirExists
-> return (Left (BadLocNonexistantFile pkglocstr)) -> return (Left (BadLocNonexistantFile pkglocstr))
......
...@@ -83,8 +83,8 @@ testExceptionInFindingPackage2 config = do ...@@ -83,8 +83,8 @@ testExceptionInFindingPackage2 config = do
BadPackageLocations locs <- expectException "BadPackageLocations" $ BadPackageLocations locs <- expectException "BadPackageLocations" $
void $ planProject testdir config void $ planProject testdir config
case locs of case locs of
[BadLocGlobBadMatches "./" [BadLocDirNoCabalFile "."]] -> return () [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return ()
_ -> assertFailure $ "expected BadLocGlobBadMatches, got " ++ show locs _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs
cleanProject testdir cleanProject testdir
where where
testdir = "exception/no-pkg2" testdir = "exception/no-pkg2"
......
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