From 06323ac20f62b9e69781ed0059f4df563fedd733 Mon Sep 17 00:00:00 2001
From: Nicolas Rolland <nicolas.rolland@gmail.com>
Date: Fri, 30 Oct 2015 19:05:41 +0100
Subject: [PATCH] adding logging to findCradle methods

---
 Language/Haskell/GhcMod/Cradle.hs      | 17 +++++++++++------
 Language/Haskell/GhcMod/Debug.hs       |  5 +++--
 Language/Haskell/GhcMod/Monad.hs       | 18 ++++++++++--------
 Language/Haskell/GhcMod/Monad/Types.hs | 19 +++++++++++++++++++
 4 files changed, 43 insertions(+), 16 deletions(-)

diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs
index 3fcb877..6dc744b 100644
--- a/Language/Haskell/GhcMod/Cradle.hs
+++ b/Language/Haskell/GhcMod/Cradle.hs
@@ -15,6 +15,8 @@ import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Stack
+import Language.Haskell.GhcMod.Logging
+
 
 import Control.Applicative
 import Control.Monad
@@ -30,10 +32,10 @@ import Prelude
 --   Find a cabal file by tracing ancestor directories.
 --   Find a sandbox according to a cabal sandbox config
 --   in a cabal directory.
-findCradle :: (IOish m, GmOut m) => m Cradle
+findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle
 findCradle = findCradle' =<< liftIO getCurrentDirectory
 
-findCradle' :: (IOish m, GmOut m) => FilePath -> m Cradle
+findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
 findCradle' dir = run $
     msum [ stackCradle dir
          , cabalCradle dir
@@ -42,7 +44,7 @@ findCradle' dir = run $
          ]
  where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
 
-findSpecCradle :: (IOish m, GmOut m) => FilePath -> m Cradle
+findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
 findSpecCradle dir = do
     let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]
     cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
@@ -77,7 +79,7 @@ cabalCradle wdir = do
       , cradleDistDir    = "dist"
       }
 
-stackCradle :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle
+stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
 stackCradle wdir = do
 #if !MIN_VERSION_ghc(7,8,0)
     -- GHC < 7.8 is not supported by stack
@@ -91,7 +93,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 $ setupConfigPath "dist") $ mzero
+    whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ do
+                      gmLog GmDebug "" $ (text
+                            "'dist/setup-config' exists, ignoring Stack and using cabal-install instead.") 
+                      mzero
 
     senv <- MaybeT $ getStackEnv cabalDir
 
@@ -104,7 +109,7 @@ stackCradle wdir = do
       , cradleDistDir    = seDistDir senv
       }
 
-stackCradleSpec :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle
+stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
 stackCradleSpec wdir = do
   crdl <- stackCradle wdir
   case crdl of
diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs
index c1dcc02..2fd7bb0 100644
--- a/Language/Haskell/GhcMod/Debug.hs
+++ b/Language/Haskell/GhcMod/Debug.hs
@@ -3,6 +3,7 @@ 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
@@ -138,5 +139,5 @@ mapDoc kd ad m = vcat $
 ----------------------------------------------------------------
 
 -- | Obtaining root information.
-rootInfo :: (IOish m, GmOut m) => m String
-rootInfo = (++"\n") . cradleRootDir <$> findCradle
+rootInfo :: forall m. (IOish m, GmOut m) => m String
+rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))
diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs
index f11371e..91ee122 100644
--- a/Language/Haskell/GhcMod/Monad.hs
+++ b/Language/Haskell/GhcMod/Monad.hs
@@ -52,17 +52,17 @@ import Exception
 import System.Directory
 import Prelude
 
-withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a
+withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog)  -> m a) -> m a
 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
+       gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
+                
+withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
 withGhcModEnv' withCradle dir opts f =
-    withCradle dir $ \crdl ->
+    withCradle dir $ \(crdl,lg) ->
       withCradleRootDir crdl $
-        f $ GhcModEnv opts crdl
+        f (GhcModEnv opts crdl, lg)
  where
    withCradleRootDir (cradleRootDir -> projdir) a = do
        cdir <- liftIO $ getCurrentDirectory
@@ -97,9 +97,11 @@ runGhcModT :: IOish m
            -> m (Either GhcModError a, GhcModLog)
 runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do
     runGmOutT opt $
-      withGhcModEnv dir' opt $ \env ->
+      withGhcModEnv dir' opt $ \(env,lg) ->
         first (fst <$>) <$> runGhcModT' env defaultGhcModState
-          (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
+          ( gmlJournal lg >>
+            gmSetLogLevel (ooptLogLevel $ optOutput opt) >>
+            action)
 
 -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
 -- computation. Note that if the computation that returned @result@ modified the
diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs
index 60e2935..7a51276 100644
--- a/Language/Haskell/GhcMod/Monad/Types.hs
+++ b/Language/Haskell/GhcMod/Monad/Types.hs
@@ -322,6 +322,11 @@ instance (Monad m, GmLog m) => GmLog (StateT s m) where
     gmlHistory = lift gmlHistory
     gmlClear = lift gmlClear
 
+instance (Monad m, GmLog m) => GmLog (MaybeT  m) where
+    gmlJournal = lift . gmlJournal
+    gmlHistory = lift gmlHistory
+    gmlClear = lift gmlClear
+
 -- GmOut -----------------------------------------
 class Monad m => GmOut m where
     gmoAsk :: m GhcModOut
@@ -338,6 +343,12 @@ instance GmOut m => GmOut (GmT m) where
 instance GmOut m => GmOut (StateT s m) where
     gmoAsk = lift gmoAsk
 
+instance GmOut m => GmOut (JournalT w m) where
+    gmoAsk = lift gmoAsk
+
+instance GmOut m => GmOut (MaybeT m) where
+    gmoAsk = lift gmoAsk
+
 instance Monad m => MonadJournal GhcModLog (GmT m) where
   journal !w = GmT $ lift $ lift $ (journal w)
   history    = GmT $ lift $ lift $ history
@@ -519,6 +530,14 @@ instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) wher
     gmask = liftBaseOp gmask . liftRestore
      where liftRestore f r = f $ liftBaseOp_ r
 
+instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (JournalT w m) where
+    gcatch act handler = control $ \run ->
+        run act `gcatch` (run . handler)
+
+    gmask = liftBaseOp gmask . liftRestore
+     where liftRestore f r = f $ liftBaseOp_ r
+
+
 ----------------------------------------------------------------
 
 options :: GmEnv m => m Options