Stop search early in 'find*File' (Fix #774)

We now stop the search early instead of examining all directories on
from CWD to /.

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -24,6 +24,7 @@ import Control.Arrow (second)
 import Control.Applicative
 import Control.Exception as E
 import Control.Monad
+import Control.Monad.Trans.Maybe
 import Data.List
 import Data.Char
 import Data.Maybe
@@ -51,31 +52,35 @@ type FileName = String
 -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'
 -- or 'GMETooManyCabalFiles'
 findCabalFile :: FilePath -> IO (Maybe FilePath)
-findCabalFile dir = do
+findCabalFile dir = findFileInParentsP isCabalFile pick dir
-    -- List of directories and all cabal file candidates
+  where
-    dcs <- findFileInParentsP  isCabalFile dir :: IO ([(DirPath, [FileName])])
+    pick [] = Nothing
-    let css = uncurry appendDir `map` dcs :: [[FilePath]]
+    pick [cf] = Just cf
-    case find (not . null) css of
+    pick cfs  = throw $ GMETooManyCabalFiles cfs
-      Nothing -> return Nothing
-      Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs
-      Just (a:_)       -> return (Just a)
-      Just []          -> error "findCabalFile"
- where
-   appendDir :: DirPath -> [FileName] -> [FilePath]
-   appendDir d fs = (d </>) `map` fs
 
 findStackConfigFile :: FilePath -> IO (Maybe FilePath)
-findStackConfigFile dir = do
+findStackConfigFile dir =
-    fs <- map (second listToMaybe) <$> findFileInParentsP  (=="stack.yaml") dir
+    findFileInParentsP (=="stack.yaml") pick dir
-    case find (isJust . snd) fs of
+  where
-      Nothing           -> return Nothing
+    pick []     = Nothing
-      Just (d, Just a)  -> return $ Just $ d </> a
+    pick (sf:_) = Just sf
-      Just (_, Nothing) -> error "findStackConfigFile"
+
+findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)
+findCabalSandboxDir dir =
+  fmap takeDirectory <$> findFileInParentsP isSandboxConfig pick dir
+ where
+   isSandboxConfig = (==sandboxConfigFileName)
+   pick []     = Nothing
+   pick (sc:_) = Just sc
+
+findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)
+findCustomPackageDbFile dir =
+    mightExist $ dir </> "ghc-mod.package-db-stack"
 
 -- | Get path to sandbox config file
 getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)
 getSandboxDb crdl = do
-  mConf <-traverse readFile =<< mightExist (sandboxConfigFile crdl)
+  mConf <- traverse readFile =<< mightExist (sandboxConfigFile crdl)
   bp <- buildPlatform readProcess
   return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf)
 
@@ -121,12 +126,23 @@ takeExtension' p =
       then "" -- just ".cabal" is not a valid cabal file
       else takeExtension p
 
--- | @findFileInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all
+-- | @findFileInParentsP p r dir@ Look for files satisfying @p@ in @dir@ and all
+-- it's parent directories. Files found to satisfy @p@ in a given directory are
+-- passed to @r@ and if this yields a 'Just' value the search finishes early
+-- without examinig any more directories and this value is returned.
+findFileInParentsP :: (FilePath -> Bool)
+                   -> ([FilePath] -> Maybe a)
+                   -> FilePath
+                   -> IO (Maybe a)
+findFileInParentsP p r dir = runMaybeT $
+    join $ msum <$> map (MaybeT . fmap r) <$> liftIO (findFilesInParentsP p dir)
+
+-- | @findFilesInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all
 -- it's parent directories.
-findFileInParentsP :: (FilePath -> Bool) -> FilePath
+findFilesInParentsP :: (FilePath -> Bool) -> FilePath
-                   -> IO [(DirPath, [FileName])]
+                   -> IO [IO [FilePath]]
-findFileInParentsP p dir' = U.makeAbsolute' dir' >>= \dir ->
+findFilesInParentsP p dir' = U.makeAbsolute' dir' >>= \dir -> return $
-    getFilesP p `zipMapM` parents dir
+    map (fmap (map (dir </>)) . getFilesP p) $ parents dir
 
 -- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.
 getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]
@@ -140,19 +156,6 @@ getFilesP p dir = filterM p' =<< getDirectoryContentsSafe
         then getDirectoryContents dir
         else return []
 
-findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)
-findCabalSandboxDir dir = do
-  dss <- findFileInParentsP isSandboxConfig dir
-  return $ case find (not . null . snd) $ dss of
-             Just (sbDir, _:_) -> Just sbDir
-             _ -> Nothing
-
- where
-   isSandboxConfig = (==sandboxConfigFileName)
-
-zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
-zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as
-
 -- | @parents dir@. Returns all parent directories of @dir@ including @dir@.
 --
 -- Examples
@@ -237,11 +240,3 @@ mergedPkgOptsCacheFile dist =
 pkgDbStackCacheFile :: FilePath -> FilePath
 pkgDbStackCacheFile dist =
     setupConfigPath dist <.> "ghc-mod.package-db-stack"
-
--- | @findCustomPackageDbFile dir@. Searches for a @ghc-mod.package-db-stack@ file in @dir@.
--- If it exists in the given directory it is returned otherwise @findCradleFile@
--- returns @Nothing@
-findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)
-findCustomPackageDbFile directory = do
-    let path = directory </> "ghc-mod.package-db-stack"
-    mightExist path