86 lines
2.5 KiB
Haskell
86 lines
2.5 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 Control.Exception.IOChoice ((||>))
|
|
import System.Directory (getCurrentDirectory, removeDirectoryRecursive,
|
|
getTemporaryDirectory)
|
|
import System.FilePath (takeDirectory,pathSeparators,splitDrive)
|
|
import System.IO.Temp
|
|
|
|
|
|
----------------------------------------------------------------
|
|
|
|
-- | 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
|
|
|
|
newTempDir :: FilePath -> IO FilePath
|
|
newTempDir dir =
|
|
flip createTempDirectory uniqPathName =<< getTemporaryDirectory
|
|
where
|
|
uniqPathName = "ghc-mod" ++ map escapeSlash (snd $ splitDrive dir)
|
|
|
|
escapeSlash c | c `elem` pathSeparators = '-'
|
|
escapeSlash c = c
|
|
|
|
cleanupCradle :: Cradle -> IO ()
|
|
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
|
|
|
|
cabalCradle :: FilePath -> IO Cradle
|
|
cabalCradle wdir = do
|
|
Just cabalFile <- findCabalFiles 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
|