Use existence of cabal/stack as cradle indicator

Also add some more "info" logging for which cradle was picked.

Language/Haskell/GhcMod/Cradle.hs

@@ -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

Language/Haskell/GhcMod/Debug.hs

@@ -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"

Language/Haskell/GhcMod/Monad.hs

@@ -53,11 +53,17 @@ import System.Directory
 import System.IO.Unsafe
 import Prelude
 
-withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog)  -> m a) -> m a
-withGhcModEnv = withGhcModEnv' withCradle
+withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
+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

src/GHCMod.hs

@@ -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 ""

test/CradleSpec.hs

@@ -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"
 

test/PathsAndFilesSpec.hs

@@ -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

test/TestUtils.hs

@@ -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