Supporting the sandbox of Cabal 1.18.0.

Support for cabal-dev was obsoleted.
This commit is contained in:
Kazu Yamamoto 2013-09-05 16:38:17 +09:00
parent 5e53841451
commit 318b376b30

View File

@ -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
let sbox = cdir </> "cabal-dev"
pkgConf = packageConfName sbox strver
exist <- doesDirectoryExist pkgConf
Just (cdir,cfile,Nothing) -> do
return Cradle {
cradleCurrentDir = wdir
, 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
checkPackageConf path ver = do
let conf = packageConfName path ver
exist <- doesDirectoryExist conf
if exist then
return conf
sandboxConfig :: String
sandboxConfig = "cabal.sandbox.config"
sandboxDir :: String
sandboxDir = ".cabal-sandbox"
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)