ghc-mod/Language/Haskell/GhcMod/Cradle.hs

131 lines
3.9 KiB
Haskell
Raw Normal View History

2013-09-21 09:37:33 +00:00
module Language.Haskell.GhcMod.Cradle (
findCradle
, findCradle'
2013-09-21 09:37:33 +00:00
, findCradleWithoutSandbox
, cleanupCradle
2013-09-21 09:37:33 +00:00
) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
import Control.Applicative ((<$>))
2014-03-27 06:21:18 +00:00
import qualified Control.Exception as E
import Control.Exception.IOChoice ((||>))
import Control.Monad (filterM)
import Data.List (isSuffixOf)
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive)
import System.FilePath ((</>), takeDirectory)
import System.IO.Temp
----------------------------------------------------------------
2013-05-20 05:28:56 +00:00
-- | Finding 'Cradle'.
2013-09-20 06:53:51 +00:00
-- Find a cabal file by tracing ancestor directories.
-- Find a sandbox according to a cabal sandbox config
-- in a cabal directory.
findCradle :: IO Cradle
2014-07-17 08:16:44 +00:00
findCradle = findCradle' =<< getCurrentDirectory
findCradle' :: FilePath -> IO Cradle
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
newTempDir :: FilePath -> IO FilePath
newTempDir dir =
flip createTempDirectory uniqPathName =<< getTemporaryDirectory
where
uniqPathName = "ghc-mod" ++ map escapeSlash dir
escapeSlash '/' = '-'
escapeSlash c = c
cleanupCradle :: Cradle -> IO ()
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
cabalCradle :: FilePath -> IO Cradle
cabalCradle wdir = do
(rdir,cfile) <- cabalDir wdir
pkgDbStack <- getPackageDbStack rdir
tmpDir <- newTempDir rdir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = rdir
, cradleTempDir = tmpDir
, cradleCabalFile = Just cfile
, cradlePkgDbStack = pkgDbStack
}
sandboxCradle :: FilePath -> IO Cradle
sandboxCradle wdir = do
rdir <- getSandboxDir wdir
pkgDbStack <- getPackageDbStack rdir
tmpDir <- newTempDir rdir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = rdir
, cradleTempDir = tmpDir
, cradleCabalFile = Nothing
, cradlePkgDbStack = pkgDbStack
}
plainCradle :: FilePath -> IO Cradle
plainCradle wdir = do
tmpDir <- newTempDir wdir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = wdir
, cradleTempDir = tmpDir
, cradleCabalFile = Nothing
, cradlePkgDbStack = [GlobalDb, UserDb]
}
2013-09-21 09:37:33 +00:00
-- Just for testing
findCradleWithoutSandbox :: IO Cradle
findCradleWithoutSandbox = do
cradle <- findCradle
return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME
2013-09-21 09:37:33 +00:00
----------------------------------------------------------------
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)
cabalDir :: FilePath -> IO (FilePath,FilePath)
cabalDir dir = do
cnts <- getCabalFiles dir
case cnts of
2014-03-27 06:21:18 +00:00
[] | dir' == dir -> E.throwIO $ userError "cabal files not found"
| otherwise -> cabalDir dir'
cfile:_ -> return (dir,dir </> cfile)
where
dir' = takeDirectory dir
getCabalFiles :: FilePath -> IO [FilePath]
getCabalFiles dir = getFiles >>= filterM doesCabalFileExist
where
isCabal name = cabalSuffix `isSuffixOf` name
&& length name > cabalSuffixLength
getFiles = filter isCabal <$> getDirectoryContents dir
doesCabalFileExist file = doesFileExist $ dir </> file
----------------------------------------------------------------
getSandboxDir :: FilePath -> IO FilePath
getSandboxDir dir = do
exist <- doesFileExist sfile
if exist then
return dir
else if dir == dir' then
E.throwIO $ userError "sandbox not found"
else
getSandboxDir dir'
where
sfile = dir </> "cabal.sandbox.config"
dir' = takeDirectory dir