From bb3333efe33bdd12640d803f64accc642005f544 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= <dxld@darkboxed.org>
Date: Sat, 9 Jan 2016 23:21:59 +0100
Subject: [PATCH] Cleanup logging in Cradle

---
 Language/Haskell/GhcMod/Cradle.hs      | 11 +++--------
 Language/Haskell/GhcMod/Monad/Log.hs   |  2 +-
 Language/Haskell/GhcMod/Monad/Types.hs |  8 ++++++++
 Language/Haskell/GhcMod/Stack.hs       | 13 +++++++++----
 4 files changed, 21 insertions(+), 13 deletions(-)

diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs
index 9194752..199349f 100644
--- a/Language/Haskell/GhcMod/Cradle.hs
+++ b/Language/Haskell/GhcMod/Cradle.hs
@@ -101,15 +101,10 @@ 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."
-                      mzero
+      gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
+      mzero
 
-    senv <- MaybeT $
-      let handler err@(GMEStackBootstrap _) = do
-            gmLog GmWarning "" $ gmeDoc err
-            return Nothing
-          handler err = throw err
-      in gcatch (getStackEnv cabalDir) handler
+    senv <- MaybeT $ getStackEnv cabalDir
 
     return Cradle {
         cradleProject    = StackProject senv
diff --git a/Language/Haskell/GhcMod/Monad/Log.hs b/Language/Haskell/GhcMod/Monad/Log.hs
index f0b245b..4da0fec 100644
--- a/Language/Haskell/GhcMod/Monad/Log.hs
+++ b/Language/Haskell/GhcMod/Monad/Log.hs
@@ -62,7 +62,7 @@ instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where
     gmlHistory = lift gmlHistory
     gmlClear = lift gmlClear
 
-instance (Monad m, GmLog m) => GmLog (MaybeT  m) where
+instance (Monad m, GmLog m) => GmLog (MaybeT m) where
     gmlJournal = lift . gmlJournal
     gmlHistory = lift gmlHistory
     gmlClear = lift gmlClear
diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs
index 8b2ac50..1424f4c 100644
--- a/Language/Haskell/GhcMod/Monad/Types.hs
+++ b/Language/Haskell/GhcMod/Monad/Types.hs
@@ -84,6 +84,7 @@ import Control.Monad
 import Control.Monad.Reader (ReaderT(..))
 import Control.Monad.State.Strict (StateT(..))
 import Control.Monad.Trans.Journal (JournalT)
+import Control.Monad.Trans.Maybe (MaybeT)
 
 import Control.Monad.Trans.Control
 
@@ -186,6 +187,13 @@ instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (Journal
     gmask = liftBaseOp gmask . liftRestore
      where liftRestore f r = f $ liftBaseOp_ r
 
+instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (MaybeT m) where
+    gcatch act handler = control $ \run ->
+        run act `gcatch` (run . handler)
+
+    gmask = liftBaseOp gmask . liftRestore
+     where liftRestore f r = f $ liftBaseOp_ r
+
 
 ----------------------------------------------------------------
 
diff --git a/Language/Haskell/GhcMod/Stack.hs b/Language/Haskell/GhcMod/Stack.hs
index 6cce20e..e919761 100644
--- a/Language/Haskell/GhcMod/Stack.hs
+++ b/Language/Haskell/GhcMod/Stack.hs
@@ -33,6 +33,8 @@ import Exception
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Output
+import Language.Haskell.GhcMod.Logging
+import Language.Haskell.GhcMod.Error
 import qualified Language.Haskell.GhcMod.Utils as U
 import Prelude
 
@@ -46,7 +48,7 @@ patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do
     }
 patchStackPrograms _crdl progs = return progs
 
-getStackEnv :: (IOish m, GmOut m) => FilePath -> m (Maybe StackEnv)
+getStackEnv :: (IOish m, GmOut m, GmLog m) => FilePath -> m (Maybe StackEnv)
 getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do
     env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"]
     let look k = fromJust $ lookup k env
@@ -80,11 +82,14 @@ findExecutablesInDirectories' path binary =
 
          exeExtension = if isWindows then "exe" else ""
 
-readStack :: (IOish m, GmOut m) => [String] -> MaybeT m String
+readStack :: (IOish m, GmOut m, GmLog m) => [String] -> MaybeT m String
 readStack args = do
   stack <- MaybeT $ liftIO $ findExecutable "stack"
   readProc <- lift gmReadProcess
-  lift $ flip gcatch (\(e :: IOError) -> exToErr e) $ do
+  flip gcatch handler $ do
     liftIO $ evaluate =<< readProc stack args ""
  where
-   exToErr = throw . GMEStackBootstrap . GMEString . show
+   handler (e :: IOError) = do
+     gmLog GmWarning "readStack" $ gmeDoc $ exToErr e
+     mzero
+   exToErr = GMEStackBootstrap . GMEString . show