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

187 lines
6.2 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Cradle
#ifndef SPEC
(
2013-09-21 09:37:33 +00:00
findCradle
, findCradle'
2015-11-25 15:06:24 +00:00
, findCradleNoLog
, findSpecCradle
, cleanupCradle
)
#endif
where
2014-11-01 21:02:47 +00:00
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Monad.Types
2014-11-01 21:02:47 +00:00
import Language.Haskell.GhcMod.Types
2014-11-02 18:00:25 +00:00
import Language.Haskell.GhcMod.Utils
2015-09-15 03:25:00 +00:00
import Language.Haskell.GhcMod.Stack
2015-10-30 18:05:41 +00:00
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Error
2015-10-30 18:05:41 +00:00
import Safe
import Control.Applicative
import Control.Monad.Trans.Maybe
import Data.Maybe
import System.Directory
import System.FilePath
import System.Environment
2015-08-03 01:09:56 +00:00
import Prelude
2015-11-25 15:06:24 +00:00
import Control.Monad.Trans.Journal (runJournalT)
----------------------------------------------------------------
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 :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle
findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory
findCradleNoLog :: forall m. (IOish m, GmOut m) => Programs -> m Cradle
findCradleNoLog progs =
fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))
findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
findCradle' Programs { stackProgram, cabalProgram } dir = run $
msum [ stackCradle stackProgram dir
, cabalCradle cabalProgram dir
, sandboxCradle dir
, plainCradle dir
]
where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
findSpecCradle ::
(GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
findSpecCradle Programs { stackProgram, cabalProgram } dir = do
let cfs = [ stackCradleSpec stackProgram
, cabalCradle cabalProgram
, sandboxCradle
]
cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
gcs <- filterM isNotGmCradle cs
fillTempDir =<< case gcs of
[] -> fromJust <$> runMaybeT (plainCradle dir)
c:_ -> return c
where
2015-09-14 03:59:01 +00:00
isNotGmCradle crdl =
liftIO $ not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")
cleanupCradle :: Cradle -> IO ()
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
fillTempDir :: IOish m => Cradle -> m Cradle
fillTempDir crdl = do
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir }
cabalCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
cabalCradle cabalProg wdir = do
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
gmLog GmInfo "" $ text "Found Cabal project at" <+>: text cabalDir
-- If cabal doesn't exist the user probably wants to use something else
whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do
gmLog GmInfo "" $ text "'cabal' executable wasn't found, trying next project type"
mzero
gmLog GmInfo "" $ text "Using Cabal project at" <+>: text cabalDir
return Cradle {
cradleProject = CabalProject
2015-08-12 07:25:13 +00:00
, cradleCurrentDir = wdir
2014-11-01 21:02:47 +00:00
, cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir"
2014-11-01 21:02:47 +00:00
, cradleCabalFile = Just cabalFile
2015-08-18 09:41:14 +00:00
, cradleDistDir = "dist"
}
stackCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
stackCradle stackProg wdir = do
2016-07-17 20:32:35 +00:00
#if __GLASGOW_HASKELL__ < 708
2015-11-26 18:21:15 +00:00
-- GHC < 7.8 is not supported by stack
mzero
#endif
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
2015-08-17 05:41:46 +00:00
let cabalDir = takeDirectory cabalFile
_stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir
gmLog GmInfo "" $ text "Found Stack project at" <+>: text cabalDir
stackExeSet <- liftIO $ isJust <$> lookupEnv "STACK_EXE"
stackExeExists <- liftIO $ isJust <$> findExecutable stackProg
setupCfgExists <- liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist"
case (stackExeExists, stackExeSet) of
(False, True) -> do
gmLog GmWarning "" $ text "'stack' executable wasn't found but STACK_EXE is set, trying next project type"
mzero
(False, False) -> do
gmLog GmInfo "" $ text "'stack' executable wasn't found, trying next project type"
mzero
(True, True) -> do
gmLog GmWarning "" $ text "STACK_EXE set, preferring Stack project"
(True, False) | setupCfgExists -> do
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack project"
mzero
(True, False) -> return ()
2016-01-09 22:21:59 +00:00
senv <- MaybeT $ getStackEnv cabalDir stackProg
2015-08-17 05:41:46 +00:00
gmLog GmInfo "" $ text "Using Stack project at" <+>: text cabalDir
2015-08-17 05:41:46 +00:00
return Cradle {
cradleProject = StackProject senv
2015-08-17 05:41:46 +00:00
, cradleCurrentDir = wdir
, cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile
, cradleDistDir = seDistDir senv
2015-08-17 05:41:46 +00:00
}
stackCradleSpec ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
stackCradleSpec stackProg wdir = do
crdl <- stackCradle stackProg wdir
2015-09-14 05:11:45 +00:00
case crdl of
Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
b <- isGmDistDir seDistDir
when b mzero
return crdl
_ -> error "stackCradleSpec"
where
isGmDistDir dir =
liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")
sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
sandboxCradle wdir = do
sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
gmLog GmInfo "" $ text "Using sandbox project at" <+>: text sbDir
return Cradle {
cradleProject = SandboxProject
2015-08-12 07:25:13 +00:00
, cradleCurrentDir = wdir
2014-11-01 21:02:47 +00:00
, cradleRootDir = sbDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
2015-08-18 09:41:14 +00:00
, cradleDistDir = "dist"
}
plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
plainCradle wdir = do
gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project"
return $ Cradle {
cradleProject = PlainProject
2015-08-12 07:25:13 +00:00
, cradleCurrentDir = wdir
, cradleRootDir = wdir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
2015-08-18 09:41:14 +00:00
, cradleDistDir = "dist"
}