diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 45ef00d..5bd5c99 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -41,18 +41,17 @@ findCradle' dir = run $ ] where run a = fillTempDir =<< (fromJust <$> runMaybeT a) -findSpecCradle :: FilePath -> IO Cradle +findSpecCradle :: (IOish m, GmOut m) => FilePath -> m Cradle findSpecCradle dir = do - let cfs = [cabalCradle, sandboxCradle] + let cfs = [stackCradle, cabalCradle, sandboxCradle] cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs gcs <- filterM isNotGmCradle cs fillTempDir =<< case gcs of [] -> fromJust <$> runMaybeT (plainCradle dir) c:_ -> return c where - isNotGmCradle :: Cradle -> IO Bool - isNotGmCradle crdl = do - not <$> doesFileExist (cradleRootDir crdl "ghc-mod.cabal") + isNotGmCradle crdl = + liftIO $ not <$> doesFileExist (cradleRootDir crdl "ghc-mod.cabal") cleanupCradle :: Cradle -> IO () cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 76a74a5..7fe5a33 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -26,6 +26,7 @@ module Language.Haskell.GhcMod.Monad ( , runGmlTWith , runGmPkgGhc , withGhcModEnv + , withGhcModEnv' , module Language.Haskell.GhcMod.Monad.Types ) where @@ -52,9 +53,15 @@ import System.Directory import Prelude withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a -withGhcModEnv dir opts f = +withGhcModEnv = withGhcModEnv' withCradle + where + withCradle dir = + gbracket (findCradle' dir) (liftIO . cleanupCradle) + +withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> (Cradle -> m a) -> m a) -> FilePath -> Options -> (GhcModEnv -> m a) -> m a +withGhcModEnv' withCradle dir opts f = withStdoutGateway $ - withCradle $ \crdl -> + withCradle dir $ \crdl -> withCradleRootDir crdl $ f $ GhcModEnv opts crdl where @@ -62,9 +69,6 @@ withGhcModEnv dir opts f = c <- gmoChan <$> gmoAsk gbracket_ (liftIO $ forkIO $ stdoutGateway c) (liftIO . killThread) a - withCradle = - gbracket (findCradle' dir) (liftIO . cleanupCradle) - withCradleRootDir (cradleRootDir -> projdir) = gbracket_ (liftIO $ setCurrentDirectory projdir >> getCurrentDirectory) (liftIO . setCurrentDirectory) diff --git a/test/TestUtils.hs b/test/TestUtils.hs index d5a1429..13d4de0 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -44,12 +44,12 @@ extract action = do Right a -> return a Left e -> error $ show e -withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a +withSpecCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a withSpecCradle cradledir f = - gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f + gbracket (findSpecCradle cradledir) (liftIO . cleanupCradle) f withGhcModEnvSpec :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a -withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f +withGhcModEnvSpec = withGhcModEnv' withSpecCradle runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runGhcModTSpec opt action = do diff --git a/test/doctests.hs b/test/doctests.hs index 03d710f..6659d8c 100644 --- a/test/doctests.hs +++ b/test/doctests.hs @@ -9,7 +9,7 @@ main = doctest , "-package", "transformers-" ++ VERSION_transformers , "-package", "mtl-" ++ VERSION_mtl , "-package", "directory-" ++ VERSION_directory - , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators" + , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators", "-XViewPatterns" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h"