adding logging to findCradle methods

This commit is contained in:
Nicolas Rolland 2015-10-30 19:05:41 +01:00
parent 16c69b2743
commit 06323ac20f
4 changed files with 43 additions and 16 deletions

View File

@ -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

View File

@ -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))

View File

@ -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)
gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> (Cradle -> m a) -> m a) -> FilePath -> Options -> (GhcModEnv -> m a) -> m a
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

View File

@ -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