Cleanup errors and logging a bit

test/TestUtils.hs

@@ -1,11 +1,10 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module TestUtils (
     run
   , runD
   , runD'
-  , runI
---  , runID
-  , runIsolatedGhcMod
-  , isolateCradle
+  , runE
+  , runNullLog
   , shouldReturnError
   , isPkgDbAt
   , isPkgConfDAt
@@ -13,18 +12,26 @@ module TestUtils (
   , module Language.Haskell.GhcMod.Types
   ) where
 
+import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.Types
 
+import Control.Arrow
+import Control.Applicative
+import Control.Monad (when)
+import Control.Monad.Error (ErrorT, runErrorT)
+import Control.Monad.Trans.Journal
 import Data.List.Split
+import Data.String
 import System.FilePath
+import System.Directory
 import Test.Hspec
 
-isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
-isolateCradle action =
-    local modifyEnv  $ action
- where
-    modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
+import Exception
+
+testLogLevel :: GmLogLevel
+testLogLevel = GmException
 
 extract :: Show e => IO (Either e a, w) -> IO a
 extract action = do
@@ -33,28 +40,46 @@ extract action = do
     Right a ->  return a
     Left e -> error $ show e
 
-runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a
-runIsolatedGhcMod opt action = do
-  extract $ runGhcModT opt $ isolateCradle action
+withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
+withSpecCradle cradledir f =
+    gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f
 
--- | Run GhcMod in isolated cradle with default options
---runID :: GhcModT IO a -> IO a
---runID = runIsolatedGhcMod defaultOptions
+withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
+withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f
 
--- | Run GhcMod in isolated cradle
-runI :: Options -> GhcModT IO a -> IO a
-runI = runIsolatedGhcMod
+runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
+runGhcModTSpec opt action = do
+  dir <- getCurrentDirectory
+  runGhcModTSpec' dir opt action
+
+runGhcModTSpec' :: IOish m
+    => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
+runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
+    withGhcModEnvSpec dir' opt $ \env -> do
+      first (fst <$>) <$> runGhcModT'' env defaultGhcModState
+        (gmSetLogLevel (logLevel opt) >> action)
 
 -- | Run GhcMod
 run :: Options -> GhcModT IO a -> IO a
-run opt a = extract $ runGhcModT opt a
+run opt a = extract $ runGhcModTSpec opt a
 
 -- | Run GhcMod with default options
 runD :: GhcModT IO a -> IO a
-runD = extract . runGhcModT defaultOptions
+runD =
+    extract . runGhcModTSpec defaultOptions { logLevel = testLogLevel }
 
-runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
-runD' = runGhcModT defaultOptions
+runD' :: FilePath -> GhcModT IO a -> IO a
+runD' dir =
+    extract . runGhcModTSpec' dir defaultOptions { logLevel = testLogLevel }
+
+runE :: ErrorT e IO a -> IO (Either e a)
+runE = runErrorT
+
+runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a
+runNullLog action = do
+  (a,w) <- runJournalT action
+  when (w /= mempty) $ liftIO $ print w
+  return a
 
 shouldReturnError :: Show a
                   => IO (Either GhcModError a, GhcModLog)
@@ -80,3 +105,6 @@ isPkgConfDAt _ _ = False
 isPkgDbAt :: FilePath -> GhcPkgDb -> Bool
 isPkgDbAt d (PackageDb dir) = isPkgConfDAt d dir
 isPkgDbAt _ _ = False
+
+instance IsString ModuleName where
+    fromString = mkModuleName