Supporting the sandbox of Cabal 1.18.0.

Support for cabal-dev was obsoleted.

Language/Haskell/GhcMod/Cradle.hs

@@ -2,19 +2,24 @@ module Language.Haskell.GhcMod.Cradle (findCradle) where
 
 import Control.Applicative ((<$>))
 import Control.Exception (throwIO)
-import Control.Monad
+import Control.Monad (unless, filterM)
 import Data.List (isSuffixOf)
+import Distribution.System (buildPlatform)
+import qualified Distribution.Text as Text (display)
 import Language.Haskell.GhcMod.Types
-import System.Directory
+import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, doesDirectoryExist)
 import System.FilePath ((</>),takeDirectory)
 
+----------------------------------------------------------------
+
 -- | Finding 'Cradle'.
 --   An error would be thrown.
 findCradle :: Maybe FilePath -- ^ A 'FilePath' for a sandbox.
            -> GHCVersion
            -> IO Cradle
 findCradle (Just sbox) strver = do
-    pkgConf <- checkPackageConf sbox strver
+    (pkgConf,exist) <- checkPackageConf sbox strver
+    unless exist $  throwIO $ userError $ pkgConf ++ " not found"
     wdir <- getCurrentDirectory
     cfiles <- cabalDir wdir
     return $ case cfiles of
@@ -24,7 +29,7 @@ findCradle (Just sbox) strver = do
           , cradleCabalFile   = Nothing
           , cradlePackageConf = Just pkgConf
           }
-        Just (cdir,cfile) -> Cradle {
+        Just (cdir,cfile,_) -> Cradle {
             cradleCurrentDir  = wdir
           , cradleCabalDir    = Just cdir
           , cradleCabalFile   = Just cfile
@@ -40,10 +45,15 @@ findCradle Nothing strver = do
           , cradleCabalFile   = Nothing
           , cradlePackageConf = Nothing
           }
-        Just (cdir,cfile) -> do
+        Just (cdir,cfile,Nothing) -> do
-            let sbox = cdir </> "cabal-dev"
+            return Cradle {
-                pkgConf = packageConfName sbox strver
+                cradleCurrentDir  = wdir
-            exist <- doesDirectoryExist pkgConf
+              , cradleCabalDir    = Just cdir
+              , cradleCabalFile   = Just cfile
+              , cradlePackageConf = Nothing
+              }
+        Just (cdir,cfile,Just sbox) -> do
+            (pkgConf,exist) <- checkPackageConf sbox strver
             return Cradle {
                 cradleCurrentDir  = wdir
               , cradleCabalDir    = Just cdir
@@ -51,7 +61,20 @@ findCradle Nothing strver = do
               , cradlePackageConf = if exist then Just pkgConf else Nothing
               }
 
-cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))
+----------------------------------------------------------------
+
+cabalSuffix :: String
+cabalSuffix = ".cabal"
+
+cabalSuffixLength :: Int
+cabalSuffixLength = length cabalSuffix
+
+-- Finding a Cabal file up to the root directory
+-- Input: a directly to investigate
+-- Output: (the path to the directory containing a Cabal file
+--         ,the path to the Cabal file
+--         ,Just the path to the sandbox directory)
+cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath,Maybe FilePath))
 cabalDir dir = do
     cnts <- (filter isCabal <$> getDirectoryContents dir)
             >>= filterM (\file -> doesFileExist (dir </> file))
@@ -59,18 +82,42 @@ cabalDir dir = do
     case cnts of
         [] | dir' == dir -> return Nothing
            | otherwise   -> cabalDir dir'
-        cfile:_          -> return $ Just (dir,dir </> cfile)
+        cfile:_          -> do
+            msbox <- checkSandbox dir
+            return $ Just (dir,dir </> cfile, msbox)
   where
-    isCabal name = ".cabal" `isSuffixOf` name && length name > 6
+    isCabal name = cabalSuffix `isSuffixOf` name
+                && length name > cabalSuffixLength
 
-packageConfName :: FilePath -> String -> FilePath
+----------------------------------------------------------------
-packageConfName path ver = path </> "packages-" ++ ver ++ ".conf"
 
-checkPackageConf :: FilePath -> String -> IO FilePath
+sandboxConfig :: String
-checkPackageConf path ver = do
+sandboxConfig = "cabal.sandbox.config"
-    let conf = packageConfName path ver
+
-    exist <- doesDirectoryExist conf
+sandboxDir :: String
-    if exist then
+sandboxDir = ".cabal-sandbox"
-        return conf
+
+checkSandbox :: FilePath -> IO (Maybe FilePath)
+checkSandbox dir = do
+    let conf = dir </> sandboxConfig
+        sbox = dir </> sandboxDir
+    sandboxConfigExists <- doesFileExist conf
+    sandboxExists <- doesDirectoryExist sbox
+    if sandboxConfigExists && sandboxExists then
+        return (Just sbox)
       else
-        throwIO $ userError $ conf ++ " not found"
+        return Nothing
+
+----------------------------------------------------------------
+
+packageConfName :: GHCVersion -> FilePath
+packageConfName strver = Text.display buildPlatform
+                      ++ "-ghc-"
+                      ++ strver
+                      ++ "-packages.conf.d"
+
+checkPackageConf :: FilePath -> GHCVersion -> IO (FilePath, Bool)
+checkPackageConf path strver = do
+    let dir = path </> packageConfName strver
+    exist <- doesDirectoryExist dir
+    return (dir,exist)