Use existence of cabal/stack as cradle indicator
Also add some more "info" logging for which cradle was picked.
This commit is contained in:
parent
0e024c9b79
commit
e495c55a8d
@ -34,24 +34,29 @@ import Control.Monad.Trans.Journal (runJournalT)
|
|||||||
-- Find a cabal file by tracing ancestor directories.
|
-- Find a cabal file by tracing ancestor directories.
|
||||||
-- Find a sandbox according to a cabal sandbox config
|
-- Find a sandbox according to a cabal sandbox config
|
||||||
-- in a cabal directory.
|
-- in a cabal directory.
|
||||||
findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle
|
findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle
|
||||||
findCradle = findCradle' =<< liftIO getCurrentDirectory
|
findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory
|
||||||
|
|
||||||
findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle
|
findCradleNoLog :: forall m. (IOish m, GmOut m) => Programs -> m Cradle
|
||||||
findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
|
findCradleNoLog progs =
|
||||||
|
fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))
|
||||||
|
|
||||||
findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
|
findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
|
||||||
findCradle' dir = run $
|
findCradle' Programs { stackProgram, cabalProgram } dir = run $
|
||||||
msum [ stackCradle dir
|
msum [ stackCradle stackProgram dir
|
||||||
, cabalCradle dir
|
, cabalCradle cabalProgram dir
|
||||||
, sandboxCradle dir
|
, sandboxCradle dir
|
||||||
, plainCradle dir
|
, plainCradle dir
|
||||||
]
|
]
|
||||||
where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
|
where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
|
||||||
|
|
||||||
findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
|
findSpecCradle ::
|
||||||
findSpecCradle dir = do
|
(GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
|
||||||
let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]
|
findSpecCradle Programs { stackProgram, cabalProgram } dir = do
|
||||||
|
let cfs = [ stackCradleSpec stackProgram
|
||||||
|
, cabalCradle cabalProgram
|
||||||
|
, sandboxCradle
|
||||||
|
]
|
||||||
cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
|
cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
|
||||||
gcs <- filterM isNotGmCradle cs
|
gcs <- filterM isNotGmCradle cs
|
||||||
fillTempDir =<< case gcs of
|
fillTempDir =<< case gcs of
|
||||||
@ -69,16 +74,18 @@ fillTempDir crdl = do
|
|||||||
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
|
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
|
||||||
return crdl { cradleTempDir = tmpDir }
|
return crdl { cradleTempDir = tmpDir }
|
||||||
|
|
||||||
cabalCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
|
cabalCradle ::
|
||||||
cabalCradle wdir = do
|
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
|
||||||
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
|
cabalCradle cabalProg wdir = do
|
||||||
let cabalDir = takeDirectory cabalFile
|
|
||||||
|
|
||||||
-- If cabal doesn't exist the user probably wants to use something else
|
-- 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"
|
gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found"
|
||||||
mzero
|
mzero
|
||||||
|
|
||||||
|
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
|
||||||
|
let cabalDir = takeDirectory cabalFile
|
||||||
|
|
||||||
|
gmLog GmInfo "" $ text "found Cabal project at" <+>: text cabalDir
|
||||||
return Cradle {
|
return Cradle {
|
||||||
cradleProject = CabalProject
|
cradleProject = CabalProject
|
||||||
, cradleCurrentDir = wdir
|
, cradleCurrentDir = wdir
|
||||||
@ -88,12 +95,19 @@ cabalCradle wdir = do
|
|||||||
, cradleDistDir = "dist"
|
, cradleDistDir = "dist"
|
||||||
}
|
}
|
||||||
|
|
||||||
stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
|
stackCradle ::
|
||||||
stackCradle wdir = do
|
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
|
||||||
|
stackCradle stackProg wdir = do
|
||||||
#if !MIN_VERSION_ghc(7,8,0)
|
#if !MIN_VERSION_ghc(7,8,0)
|
||||||
-- GHC < 7.8 is not supported by stack
|
-- GHC < 7.8 is not supported by stack
|
||||||
mzero
|
mzero
|
||||||
#endif
|
#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
|
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
|
||||||
|
|
||||||
let cabalDir = takeDirectory cabalFile
|
let cabalDir = takeDirectory cabalFile
|
||||||
@ -103,11 +117,12 @@ stackCradle wdir = do
|
|||||||
-- If dist/setup-config already exists the user probably wants to use cabal
|
-- If dist/setup-config already exists the user probably wants to use cabal
|
||||||
-- rather than stack, or maybe that's just me ;)
|
-- rather than stack, or maybe that's just me ;)
|
||||||
whenM (liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist") $ do
|
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
|
mzero
|
||||||
|
|
||||||
senv <- MaybeT $ getStackEnv cabalDir
|
senv <- MaybeT $ getStackEnv cabalDir
|
||||||
|
|
||||||
|
gmLog GmInfo "" $ text "found Stack project at" <+>: text cabalDir
|
||||||
return Cradle {
|
return Cradle {
|
||||||
cradleProject = StackProject senv
|
cradleProject = StackProject senv
|
||||||
, cradleCurrentDir = wdir
|
, cradleCurrentDir = wdir
|
||||||
@ -117,9 +132,10 @@ stackCradle wdir = do
|
|||||||
, cradleDistDir = seDistDir senv
|
, cradleDistDir = seDistDir senv
|
||||||
}
|
}
|
||||||
|
|
||||||
stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
|
stackCradleSpec ::
|
||||||
stackCradleSpec wdir = do
|
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
|
||||||
crdl <- stackCradle wdir
|
stackCradleSpec stackProg wdir = do
|
||||||
|
crdl <- stackCradle stackProg wdir
|
||||||
case crdl of
|
case crdl of
|
||||||
Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
|
Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
|
||||||
b <- isGmDistDir seDistDir
|
b <- isGmDistDir seDistDir
|
||||||
@ -130,9 +146,10 @@ stackCradleSpec wdir = do
|
|||||||
isGmDistDir dir =
|
isGmDistDir dir =
|
||||||
liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")
|
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
|
sandboxCradle wdir = do
|
||||||
sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
|
sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
|
||||||
|
gmLog GmInfo "" $ text "Found sandbox project at" <+>: text sbDir
|
||||||
return Cradle {
|
return Cradle {
|
||||||
cradleProject = SandboxProject
|
cradleProject = SandboxProject
|
||||||
, cradleCurrentDir = wdir
|
, cradleCurrentDir = wdir
|
||||||
@ -142,8 +159,9 @@ sandboxCradle wdir = do
|
|||||||
, cradleDistDir = "dist"
|
, cradleDistDir = "dist"
|
||||||
}
|
}
|
||||||
|
|
||||||
plainCradle :: IOish m => FilePath -> MaybeT m Cradle
|
plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
|
||||||
plainCradle wdir = do
|
plainCradle wdir = do
|
||||||
|
gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project"
|
||||||
return $ Cradle {
|
return $ Cradle {
|
||||||
cradleProject = PlainProject
|
cradleProject = PlainProject
|
||||||
, cradleCurrentDir = wdir
|
, cradleCurrentDir = wdir
|
||||||
|
@ -3,7 +3,6 @@ module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where
|
|||||||
import Control.Arrow (first)
|
import Control.Arrow (first)
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Trans.Journal
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Data.Char
|
import Data.Char
|
||||||
@ -167,5 +166,7 @@ mapDoc kd ad m = vcat $
|
|||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
-- | Obtaining root information.
|
-- | Obtaining root information.
|
||||||
rootInfo :: forall m. (IOish m, GmOut m) => m String
|
rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String
|
||||||
rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))
|
rootInfo = do
|
||||||
|
crdl <- findCradleNoLog =<< (optPrograms <$> options)
|
||||||
|
return $ cradleRootDir crdl ++ "\n"
|
||||||
|
@ -53,11 +53,17 @@ import System.Directory
|
|||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
|
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
|
where
|
||||||
withCradle dir =
|
withCradle dir' =
|
||||||
gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
|
gbracket
|
||||||
|
(runJournalT $ do
|
||||||
|
gmSetLogLevel $ ooptLogLevel $ optOutput opts
|
||||||
|
findCradle' (optPrograms opts) dir')
|
||||||
|
(liftIO . cleanupCradle . fst)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
cwdLock :: MVar ThreadId
|
cwdLock :: MVar ThreadId
|
||||||
cwdLock = unsafePerformIO $ newEmptyMVar
|
cwdLock = unsafePerformIO $ newEmptyMVar
|
||||||
|
@ -111,7 +111,6 @@ getFileSourceFromStdin = do
|
|||||||
else return []
|
else return []
|
||||||
|
|
||||||
wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
|
wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
|
||||||
wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
|
|
||||||
wrapGhcCommands opts cmd =
|
wrapGhcCommands opts cmd =
|
||||||
handleGmError $ runGhcModT opts $ handler $ do
|
handleGmError $ runGhcModT opts $ handler $ do
|
||||||
forM_ (reverse $ optFileMappings opts) $
|
forM_ (reverse $ optFileMappings opts) $
|
||||||
@ -141,7 +140,7 @@ ghcCommands (CmdDebug) = debugInfo
|
|||||||
ghcCommands (CmdDebugComponent ts) = componentInfo ts
|
ghcCommands (CmdDebugComponent ts) = componentInfo ts
|
||||||
ghcCommands (CmdBoot) = boot
|
ghcCommands (CmdBoot) = boot
|
||||||
-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
|
-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
|
||||||
-- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
|
ghcCommands (CmdRoot) = rootInfo
|
||||||
ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
|
ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
|
||||||
ghcCommands (CmdModules detail) = modules detail
|
ghcCommands (CmdModules detail) = modules detail
|
||||||
ghcCommands (CmdDumpSym) = dumpSymbol >> return ""
|
ghcCommands (CmdDumpSym) = dumpSymbol >> return ""
|
||||||
|
@ -37,14 +37,14 @@ spec = do
|
|||||||
it "returns the current directory" $ do
|
it "returns the current directory" $ do
|
||||||
withDirectory_ "/" $ do
|
withDirectory_ "/" $ do
|
||||||
curDir <- stripLastDot <$> canonicalizePath "/"
|
curDir <- stripLastDot <$> canonicalizePath "/"
|
||||||
res <- clean_ $ runGmOutDef findCradleNoLog
|
res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions
|
||||||
cradleCurrentDir res `shouldBe` curDir
|
cradleCurrentDir res `shouldBe` curDir
|
||||||
cradleRootDir res `shouldBe` curDir
|
cradleRootDir res `shouldBe` curDir
|
||||||
cradleCabalFile res `shouldBe` Nothing
|
cradleCabalFile res `shouldBe` Nothing
|
||||||
|
|
||||||
it "finds a cabal file and a sandbox" $ do
|
it "finds a cabal file and a sandbox" $ do
|
||||||
withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> 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`
|
cradleCurrentDir res `shouldBe`
|
||||||
"test/data/cabal-project/subdir1/subdir2"
|
"test/data/cabal-project/subdir1/subdir2"
|
||||||
@ -56,7 +56,7 @@ spec = do
|
|||||||
|
|
||||||
it "works even if a sandbox config file is broken" $ do
|
it "works even if a sandbox config file is broken" $ do
|
||||||
withDirectory "test/data/broken-sandbox" $ \dir -> 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`
|
cradleCurrentDir res `shouldBe`
|
||||||
"test" </> "data" </> "broken-sandbox"
|
"test" </> "data" </> "broken-sandbox"
|
||||||
|
|
||||||
|
@ -16,12 +16,12 @@ spec = do
|
|||||||
describe "getSandboxDb" $ do
|
describe "getSandboxDb" $ do
|
||||||
it "can parse a config file and extract the sandbox package-db" $ do
|
it "can parse a config file and extract the sandbox package-db" $ do
|
||||||
cwd <- getCurrentDirectory
|
cwd <- getCurrentDirectory
|
||||||
Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project"
|
Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project"
|
||||||
Just db <- getSandboxDb crdl
|
Just db <- getSandboxDb crdl
|
||||||
db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
|
db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
|
||||||
|
|
||||||
it "returns Nothing if the sandbox config file is broken" $ do
|
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
|
getSandboxDb crdl `shouldReturn` Nothing
|
||||||
|
|
||||||
describe "findCabalFile" $ do
|
describe "findCabalFile" $ do
|
||||||
|
@ -6,6 +6,7 @@ module TestUtils (
|
|||||||
, runE
|
, runE
|
||||||
, runNullLog
|
, runNullLog
|
||||||
, runGmOutDef
|
, runGmOutDef
|
||||||
|
, runLogDef
|
||||||
, shouldReturnError
|
, shouldReturnError
|
||||||
, isPkgDbAt
|
, isPkgDbAt
|
||||||
, isPkgConfDAt
|
, isPkgConfDAt
|
||||||
@ -43,10 +44,6 @@ extract action = do
|
|||||||
Right a -> return a
|
Right a -> return a
|
||||||
Left e -> error $ show e
|
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 :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
|
||||||
runGhcModTSpec opt action = do
|
runGhcModTSpec opt action = do
|
||||||
dir <- getCurrentDirectory
|
dir <- getCurrentDirectory
|
||||||
@ -59,6 +56,13 @@ runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
|
|||||||
withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do
|
withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do
|
||||||
first (fst <$>) <$> runGhcModT' env defaultGhcModState
|
first (fst <$>) <$> runGhcModT' env defaultGhcModState
|
||||||
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
|
(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 GhcMod
|
||||||
run :: Options -> GhcModT IO a -> IO a
|
run :: Options -> GhcModT IO a -> IO a
|
||||||
@ -88,6 +92,9 @@ runNullLog action = do
|
|||||||
runGmOutDef :: IOish m => GmOutT m a -> m a
|
runGmOutDef :: IOish m => GmOutT m a -> m a
|
||||||
runGmOutDef = runGmOutT defaultOptions
|
runGmOutDef = runGmOutT defaultOptions
|
||||||
|
|
||||||
|
runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a
|
||||||
|
runLogDef = fmap fst . runJournalT . runGmOutDef
|
||||||
|
|
||||||
shouldReturnError :: Show a
|
shouldReturnError :: Show a
|
||||||
=> IO (Either GhcModError a, GhcModLog)
|
=> IO (Either GhcModError a, GhcModLog)
|
||||||
-> Expectation
|
-> Expectation
|
||||||
|
Loading…
Reference in New Issue
Block a user