From e495c55a8db0b0940df98e9fea03c33b25de0e26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 14 May 2016 20:18:06 +0200 Subject: [PATCH] Use existence of cabal/stack as cradle indicator Also add some more "info" logging for which cradle was picked. --- Language/Haskell/GhcMod/Cradle.hs | 68 +++++++++++++++++++------------ Language/Haskell/GhcMod/Debug.hs | 7 ++-- Language/Haskell/GhcMod/Monad.hs | 14 +++++-- src/GHCMod.hs | 3 +- test/CradleSpec.hs | 6 +-- test/PathsAndFilesSpec.hs | 4 +- test/TestUtils.hs | 15 +++++-- 7 files changed, 74 insertions(+), 43 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 06ad80e..05f6b31 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 59673e0..9811e72 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/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" diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 5d90aee..96d55e5 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 531f7de..713d567 100644 --- a/src/GHCMod.hs +++ b/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 "" diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index 6396437..c62a589 100644 --- a/test/CradleSpec.hs +++ b/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" diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs index b2ac6e6..d3611f1 100644 --- a/test/PathsAndFilesSpec.hs +++ b/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 diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 9ce67b5..af5367b 100644 --- a/test/TestUtils.hs +++ b/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