ghc-mod/Language/Haskell/GhcMod/Cradle.hs
2014-11-03 00:45:27 +01:00

76 lines
2.2 KiB
Haskell

module Language.Haskell.GhcMod.Cradle (
findCradle
, findCradle'
, findCradleWithoutSandbox
, cleanupCradle
) where
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Control.Exception.IOChoice ((||>))
import System.Directory (getCurrentDirectory, removeDirectoryRecursive)
import System.FilePath (takeDirectory)
----------------------------------------------------------------
-- | Finding 'Cradle'.
-- Find a cabal file by tracing ancestor directories.
-- Find a sandbox according to a cabal sandbox config
-- in a cabal directory.
findCradle :: IO Cradle
findCradle = findCradle' =<< getCurrentDirectory
findCradle' :: FilePath -> IO Cradle
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
cleanupCradle :: Cradle -> IO ()
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
cabalCradle :: FilePath -> IO Cradle
cabalCradle wdir = do
Just cabalFile <- findCabalFile wdir
let cabalDir = takeDirectory cabalFile
pkgDbStack <- getPackageDbStack cabalDir
tmpDir <- newTempDir cabalDir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = cabalDir
, cradleTempDir = tmpDir
, cradleCabalFile = Just cabalFile
, cradlePkgDbStack = pkgDbStack
}
sandboxCradle :: FilePath -> IO Cradle
sandboxCradle wdir = do
Just sbDir <- getSandboxDb wdir
pkgDbStack <- getPackageDbStack sbDir
tmpDir <- newTempDir sbDir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = sbDir
, 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]
}
-- Just for testing
findCradleWithoutSandbox :: IO Cradle
findCradleWithoutSandbox = do
cradle <- findCradle
return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME