Use existence of cabal/stack as cradle indicator

Also add some more "info" logging for which cradle was picked.
This commit is contained in:
Daniel Gröber 2016-05-14 20:18:06 +02:00
parent 0e024c9b79
commit e495c55a8d
7 changed files with 74 additions and 43 deletions

View File

@ -34,24 +34,29 @@ import Control.Monad.Trans.Journal (runJournalT)
-- 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) => m Cradle
findCradle = findCradle' =<< liftIO getCurrentDirectory
findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle
findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory
findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle
findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
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) => FilePath -> m Cradle
findCradle' dir = run $
msum [ stackCradle dir
, cabalCradle dir
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) => FilePath -> m Cradle
findSpecCradle dir = do
let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]
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
@ -69,16 +74,18 @@ fillTempDir crdl = do
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir }
cabalCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
cabalCradle wdir = do
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
cabalCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
cabalCradle cabalProg wdir = do
-- If cabal doesn't exist the user probably wants to use something else
whenM ((==Nothing) <$> liftIO (findExecutable "cabal")) $ do
whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do
gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found"
mzero
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
gmLog GmInfo "" $ text "found Cabal project at" <+>: text cabalDir
return Cradle {
cradleProject = CabalProject
, cradleCurrentDir = wdir
@ -88,12 +95,19 @@ cabalCradle wdir = do
, cradleDistDir = "dist"
}
stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
stackCradle wdir = do
stackCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
stackCradle stackProg wdir = do
#if !MIN_VERSION_ghc(7,8,0)
-- GHC < 7.8 is not supported by stack
mzero
#endif
-- If cabal doesn't exist the user probably wants to use something else
whenM ((==Nothing) <$> liftIO (findExecutable stackProg)) $ do
gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found"
mzero
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
@ -103,11 +117,12 @@ stackCradle wdir = do
-- If dist/setup-config already exists the user probably wants to use cabal
-- rather than stack, or maybe that's just me ;)
whenM (liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist") $ do
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead"
mzero
senv <- MaybeT $ getStackEnv cabalDir
gmLog GmInfo "" $ text "found Stack project at" <+>: text cabalDir
return Cradle {
cradleProject = StackProject senv
, cradleCurrentDir = wdir
@ -117,9 +132,10 @@ stackCradle wdir = do
, cradleDistDir = seDistDir senv
}
stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
stackCradleSpec wdir = do
crdl <- stackCradle wdir
stackCradleSpec ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
stackCradleSpec stackProg wdir = do
crdl <- stackCradle stackProg wdir
case crdl of
Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
b <- isGmDistDir seDistDir
@ -130,9 +146,10 @@ stackCradleSpec wdir = do
isGmDistDir dir =
liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")
sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle
sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
sandboxCradle wdir = do
sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
gmLog GmInfo "" $ text "Found sandbox project at" <+>: text sbDir
return Cradle {
cradleProject = SandboxProject
, cradleCurrentDir = wdir
@ -142,8 +159,9 @@ sandboxCradle wdir = do
, cradleDistDir = "dist"
}
plainCradle :: IOish m => FilePath -> MaybeT m Cradle
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
, cradleCurrentDir = wdir

View File

@ -3,7 +3,6 @@ module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where
import Control.Arrow (first)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Journal
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char
@ -167,5 +166,7 @@ mapDoc kd ad m = vcat $
----------------------------------------------------------------
-- | Obtaining root information.
rootInfo :: forall m. (IOish m, GmOut m) => m String
rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))
rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String
rootInfo = do
crdl <- findCradleNoLog =<< (optPrograms <$> options)
return $ cradleRootDir crdl ++ "\n"

View File

@ -54,10 +54,16 @@ import System.IO.Unsafe
import Prelude
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
withGhcModEnv = withGhcModEnv' withCradle
withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f
where
withCradle dir =
gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
withCradle dir' =
gbracket
(runJournalT $ do
gmSetLogLevel $ ooptLogLevel $ optOutput opts
findCradle' (optPrograms opts) dir')
(liftIO . cleanupCradle . fst)
cwdLock :: MVar ThreadId
cwdLock = unsafePerformIO $ newEmptyMVar

View File

@ -111,7 +111,6 @@ getFileSourceFromStdin = do
else return []
wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
wrapGhcCommands opts cmd =
handleGmError $ runGhcModT opts $ handler $ do
forM_ (reverse $ optFileMappings opts) $
@ -141,7 +140,7 @@ ghcCommands (CmdDebug) = debugInfo
ghcCommands (CmdDebugComponent ts) = componentInfo ts
ghcCommands (CmdBoot) = boot
-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
-- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
ghcCommands (CmdRoot) = rootInfo
ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
ghcCommands (CmdModules detail) = modules detail
ghcCommands (CmdDumpSym) = dumpSymbol >> return ""

View File

@ -37,14 +37,14 @@ spec = do
it "returns the current directory" $ do
withDirectory_ "/" $ do
curDir <- stripLastDot <$> canonicalizePath "/"
res <- clean_ $ runGmOutDef findCradleNoLog
res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions
cradleCurrentDir res `shouldBe` curDir
cradleRootDir res `shouldBe` curDir
cradleCabalFile res `shouldBe` Nothing
it "finds a cabal file and a sandbox" $ do
withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
cradleCurrentDir res `shouldBe`
"test/data/cabal-project/subdir1/subdir2"
@ -56,7 +56,7 @@ spec = do
it "works even if a sandbox config file is broken" $ do
withDirectory "test/data/broken-sandbox" $ \dir -> do
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
cradleCurrentDir res `shouldBe`
"test" </> "data" </> "broken-sandbox"

View File

@ -16,12 +16,12 @@ spec = do
describe "getSandboxDb" $ do
it "can parse a config file and extract the sandbox package-db" $ do
cwd <- getCurrentDirectory
Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project"
Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project"
Just db <- getSandboxDb crdl
db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
it "returns Nothing if the sandbox config file is broken" $ do
Just crdl <- runMaybeT $ plainCradle "test/data/broken-sandbox"
Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox"
getSandboxDb crdl `shouldReturn` Nothing
describe "findCabalFile" $ do

View File

@ -6,6 +6,7 @@ module TestUtils (
, runE
, runNullLog
, runGmOutDef
, runLogDef
, shouldReturnError
, isPkgDbAt
, isPkgConfDAt
@ -43,10 +44,6 @@ extract action = do
Right a -> return a
Left e -> error $ show e
withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
withSpecCradle cradledir f = do
gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
runGhcModTSpec opt action = do
dir <- getCurrentDirectory
@ -59,6 +56,13 @@ runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do
first (fst <$>) <$> runGhcModT' env defaultGhcModState
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
where
withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
withSpecCradle cradledir f =
gbracket
(runJournalT $ findSpecCradle (optPrograms opt) cradledir)
(liftIO . cleanupCradle . fst) f
-- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a
@ -88,6 +92,9 @@ runNullLog action = do
runGmOutDef :: IOish m => GmOutT m a -> m a
runGmOutDef = runGmOutT defaultOptions
runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a
runLogDef = fmap fst . runJournalT . runGmOutDef
shouldReturnError :: Show a
=> IO (Either GhcModError a, GhcModLog)
-> Expectation