From 417cacbf8141fcef8c6d330a0bc34f42fef8c41c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= <dxld@darkboxed.org>
Date: Sat, 7 Feb 2015 16:40:22 +0100
Subject: [PATCH] Fix finding sandbox in sandbox only projects

---
 Language/Haskell/GhcMod/Cradle.hs        |  2 +-
 Language/Haskell/GhcMod/GhcPkg.hs        |  7 +--
 Language/Haskell/GhcMod/PathsAndFiles.hs | 73 ++++++++++++++++++------
 3 files changed, 57 insertions(+), 25 deletions(-)

diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs
index 94ee836..a5e652f 100644
--- a/Language/Haskell/GhcMod/Cradle.hs
+++ b/Language/Haskell/GhcMod/Cradle.hs
@@ -46,7 +46,7 @@ cabalCradle wdir = do
 
 sandboxCradle :: FilePath -> IO Cradle
 sandboxCradle wdir = do
-    Just sbDir <- getSandboxDb wdir
+    Just sbDir <- findCabalSandboxDir wdir
     pkgDbStack <- getPackageDbStack sbDir
     tmpDir <- newTempDir sbDir
     return Cradle {
diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs
index 969acda..56dc123 100644
--- a/Language/Haskell/GhcMod/GhcPkg.hs
+++ b/Language/Haskell/GhcMod/GhcPkg.hs
@@ -29,11 +29,8 @@ getPackageDbStack :: FilePath -- ^ Project Directory (where the
                                  -- cabal.sandbox.config file would be if it
                                  -- exists)
                   -> IO [GhcPkgDb]
-getPackageDbStack cdir = do
-    mSDir <- getSandboxDb cdir
-    return $ [GlobalDb] ++ case mSDir of
-                             Nothing -> [UserDb]
-                             Just db -> [PackageDb db]
+getPackageDbStack cdir =
+    ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
 
 ----------------------------------------------------------------
 
diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs
index 88c61a0..4bef50d 100644
--- a/Language/Haskell/GhcMod/PathsAndFiles.hs
+++ b/Language/Haskell/GhcMod/PathsAndFiles.hs
@@ -31,31 +31,66 @@ type FileName = String
 -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'
 -- or 'GMETooManyCabalFiles'
 findCabalFile :: FilePath -> IO (Maybe FilePath)
-findCabalFile directory = do
-    -- Look for cabal files in @dir@ and all it's parent directories
-    dcs <- getCabalFiles `zipMapM` parents directory
+findCabalFile dir = do
+    dcs <- findFileInParentsP  isCabalFile dir
     -- Extract first non-empty list, which represents a directory with cabal
     -- files.
     case find (not . null) $ uncurry appendDir `map` dcs of
       Just []          -> throw $ GMENoCabalFile
       Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs
       a  -> return $ head <$> a
- where
-   appendDir :: DirPath -> [FileName] -> [FilePath]
-   appendDir dir fs = (dir </>) `map` fs
 
--- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@.
-getCabalFiles :: DirPath -> IO [FileName]
-getCabalFiles dir =
-    filterM isCabalFile =<< getDirectoryContents dir
- where
-   isCabalFile f = do
-     exists <- doesFileExist $ dir </> f
-     return (exists && takeExtension' f == ".cabal")
+-- |
+-- >>> isCabalFile "/home/user/.cabal"
+-- False
+isCabalFile :: FilePath -> Bool
+isCabalFile f = takeExtension' f == ".cabal"
 
-   takeExtension' p = if takeFileName p == takeExtension p
-                        then ""
-                        else takeExtension p
+-- |
+-- >>> takeExtension' "/some/dir/bla.cabal"
+-- ".cabal"
+--
+-- >>> takeExtension' "some/reldir/bla.cabal"
+-- ".cabal"
+--
+-- >>> takeExtension' "bla.cabal"
+-- ".cabal"
+--
+-- >>> takeExtension' ".cabal"
+-- ""
+takeExtension' :: FilePath -> String
+takeExtension' p =
+    if takeFileName p == 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
+-- it's parent directories.
+findFileInParentsP :: (FilePath -> Bool) -> FilePath
+                   -> IO [(DirPath, [FileName])]
+findFileInParentsP p dir =
+    getFilesP p `zipMapM` parents dir
+
+-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.
+getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]
+getFilesP p dir = filterM p' =<< getDirectoryContents dir
+ where
+   p' fn = do
+     (p fn && ) <$> doesFileExist (dir </> fn)
+
+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 = (=="cabal.sandbox.config")
+
+
+appendDir :: DirPath -> [FileName] -> [FilePath]
+appendDir d fs = (d </>) `map` fs
 
 zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
 zipMapM f as = mapM (\a -> liftM (a,) $ f a) as
@@ -91,10 +126,10 @@ parents dir' =
 -- | Get path to sandbox config file
 getSandboxDb :: FilePath -- ^ Path to the cabal package root directory
                          -- (containing the @cabal.sandbox.config@ file)
-             -> IO (Maybe FilePath)
+             -> IO (Maybe GhcPkgDb)
 getSandboxDb d = do
   mConf <- traverse readFile =<< U.mightExist (d </> "cabal.sandbox.config")
-  return $ fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)
+  return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)
 
  where
    fixPkgDbVer dir =