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

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