fixing tests for logging

Language/Haskell/GhcMod/Cradle.hs

@@ -4,6 +4,7 @@ module Language.Haskell.GhcMod.Cradle
   (
     findCradle
   , findCradle'
+  , findCradleNoLog
   , findSpecCradle
   , cleanupCradle
   )
@@ -25,6 +26,8 @@ import Data.Maybe
 import System.Directory
 import System.FilePath
 import Prelude
+import Control.Monad.Trans.Journal (runJournalT)
+
 
 ----------------------------------------------------------------
 
@@ -35,6 +38,9 @@ import Prelude
 findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle
 findCradle = findCradle' =<< liftIO getCurrentDirectory
 
+findCradleNoLog  :: forall m. (IOish m, GmOut m) => m Cradle
+findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
+    
 findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
 findCradle' dir = run $
     msum [ stackCradle dir

Language/Haskell/GhcMod/Logging.hs

@@ -86,7 +86,7 @@ gmLog level loc' doc = do
 -- | Appends a collection of logs to the logging environment, with effects
 -- | if their log level specifies it should
 gmLog' :: (MonadIO m, GmLog m, GmOut m) => GhcModLog -> m ()
-gmLog' newLog@ GhcModLog { gmLogMessages } = do
+gmLog' GhcModLog { gmLogMessages } = do
   GhcModLog { gmLogLevel = Just level' } <- gmlHistory
   mapM_ (\(level, _, msgDoc) ->  when (level <= level') $ gmErrStrLn (docToString msgDoc)) gmLogMessages
   -- instance Monoid GhcModLog takes the second debug level for some reason, so we need to force this to nothing

test/CradleSpec.hs

@@ -8,7 +8,6 @@ import System.Directory (canonicalizePath)
 import System.FilePath (pathSeparator)
 import Test.Hspec
 import TestUtils
-import Prelude
 
 import Dir
 
@@ -37,14 +36,14 @@ spec = do
         it "returns the current directory" $ do
             withDirectory_ "/" $ do
                 curDir <- stripLastDot <$> canonicalizePath "/"
-                res <- clean_ $ runGmOutDef findCradle
+                res <- clean_ $ runGmOutDef findCradleNoLog
                 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 findCradle)
+                res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
 
                 cradleCurrentDir res `shouldBe`
                     "test/data/cabal-project/subdir1/subdir2"
@@ -56,7 +55,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 findCradle)
+                res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
                 cradleCurrentDir res `shouldBe`
                     "test" </> "data" </> "broken-sandbox"
 

test/TestUtils.hs

@@ -43,11 +43,11 @@ extract action = do
     Right a ->  return a
     Left e -> error $ show e
 
-withSpecCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a
+withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
 withSpecCradle cradledir f = do
-    gbracket (findSpecCradle cradledir) (liftIO . cleanupCradle) $ \crdl ->
+    gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) $ \arg@(crdl,_) ->
       bracketWorkingDirectory (cradleRootDir crdl) $
-        f crdl
+        f arg
 
 bracketWorkingDirectory ::
     (ExceptionMonad m, MonadIO m) => FilePath -> m c -> m c
@@ -69,7 +69,7 @@ runGhcModTSpec' :: IOish m
     => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
 runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
   runGmOutT opt $
-    withGhcModEnv' withSpecCradle dir' opt $ \env -> do
+    withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do
       first (fst <$>) <$> runGhcModT' env defaultGhcModState
         (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)