Cleanup logging in Cradle

This commit is contained in:
Daniel Gröber 2016-01-09 23:21:59 +01:00
parent 68cd165088
commit bb3333efe3
4 changed files with 21 additions and 13 deletions

View File

@ -104,12 +104,7 @@ stackCradle wdir = do
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead." gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
mzero mzero
senv <- MaybeT $ senv <- MaybeT $ getStackEnv cabalDir
let handler err@(GMEStackBootstrap _) = do
gmLog GmWarning "" $ gmeDoc err
return Nothing
handler err = throw err
in gcatch (getStackEnv cabalDir) handler
return Cradle { return Cradle {
cradleProject = StackProject senv cradleProject = StackProject senv

View File

@ -84,6 +84,7 @@ import Control.Monad
import Control.Monad.Reader (ReaderT(..)) import Control.Monad.Reader (ReaderT(..))
import Control.Monad.State.Strict (StateT(..)) import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Trans.Journal (JournalT) import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
@ -186,6 +187,13 @@ instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (Journal
gmask = liftBaseOp gmask . liftRestore gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r 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
---------------------------------------------------------------- ----------------------------------------------------------------

View File

@ -33,6 +33,8 @@ import Exception
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Error
import qualified Language.Haskell.GhcMod.Utils as U import qualified Language.Haskell.GhcMod.Utils as U
import Prelude import Prelude
@ -46,7 +48,7 @@ patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do
} }
patchStackPrograms _crdl progs = return progs 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 getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do
env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"] env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"]
let look k = fromJust $ lookup k env let look k = fromJust $ lookup k env
@ -80,11 +82,14 @@ findExecutablesInDirectories' path binary =
exeExtension = if isWindows then "exe" else "" 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 readStack args = do
stack <- MaybeT $ liftIO $ findExecutable "stack" stack <- MaybeT $ liftIO $ findExecutable "stack"
readProc <- lift gmReadProcess readProc <- lift gmReadProcess
lift $ flip gcatch (\(e :: IOError) -> exToErr e) $ do flip gcatch handler $ do
liftIO $ evaluate =<< readProc stack args "" liftIO $ evaluate =<< readProc stack args ""
where where
exToErr = throw . GMEStackBootstrap . GMEString . show handler (e :: IOError) = do
gmLog GmWarning "readStack" $ gmeDoc $ exToErr e
mzero
exToErr = GMEStackBootstrap . GMEString . show