some refactoring
This commit is contained in:
parent
e1d2de96c8
commit
bff86be69f
@ -100,8 +100,7 @@ stackCradle wdir = do
|
|||||||
-- If dist/setup-config already exists the user probably wants to use cabal
|
-- If dist/setup-config already exists the user probably wants to use cabal
|
||||||
-- rather than stack, or maybe that's just me ;)
|
-- rather than stack, or maybe that's just me ;)
|
||||||
whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ do
|
whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ do
|
||||||
gmLog GmWarning "" $ (text
|
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
|
||||||
"'dist/setup-config' exists, ignoring Stack and using cabal-install instead.")
|
|
||||||
mzero
|
mzero
|
||||||
|
|
||||||
senv <- MaybeT $ getStackEnv cabalDir
|
senv <- MaybeT $ getStackEnv cabalDir
|
||||||
|
@ -85,14 +85,9 @@ gmLog level loc' doc = do
|
|||||||
|
|
||||||
-- | Appends a collection of logs to the logging environment, with effects
|
-- | Appends a collection of logs to the logging environment, with effects
|
||||||
-- | if their log level specifies it should
|
-- | if their log level specifies it should
|
||||||
gmLog' :: (MonadIO m, GmLog m, GmOut m) => GhcModLog -> m ()
|
gmAppendLog :: (MonadIO m, GmLog m, GmOut m) => GhcModLog -> m ()
|
||||||
gmLog' GhcModLog { gmLogMessages } = do
|
gmAppendLog GhcModLog { gmLogMessages } = (\(level, loc, msgDoc) -> gmLog level loc msgDoc) `mapM_` gmLogMessages
|
||||||
GhcModLog { gmLogLevel = Just level' } <- gmlHistory
|
|
||||||
mapM_ (\(level, _, msgDoc) -> when (level <= level') $ gmErrStrLn (docToString msgDoc)) gmLogMessages
|
|
||||||
-- instance Monoid GhcModLog takes the second debug level for some reason, so we need to force this to nothing
|
|
||||||
gmlJournal (GhcModLog Nothing (Last Nothing) gmLogMessages)
|
|
||||||
where
|
|
||||||
docToString msgDoc = dropWhileEnd isSpace $ gmRenderDoc msgDoc
|
|
||||||
|
|
||||||
gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m ()
|
gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m ()
|
||||||
gmVomit filename doc content = do
|
gmVomit filename doc content = do
|
||||||
|
@ -100,7 +100,7 @@ runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \d
|
|||||||
withGhcModEnv dir' opt $ \(env,lg) ->
|
withGhcModEnv dir' opt $ \(env,lg) ->
|
||||||
first (fst <$>) <$> runGhcModT' env defaultGhcModState
|
first (fst <$>) <$> runGhcModT' env defaultGhcModState
|
||||||
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >>
|
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >>
|
||||||
gmLog' lg >>
|
gmAppendLog lg >>
|
||||||
action)
|
action)
|
||||||
|
|
||||||
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
|
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
|
||||||
|
Loading…
Reference in New Issue
Block a user