handling logging level

This commit is contained in:
Nicolas Rolland 2015-10-31 12:34:30 +01:00
parent 06323ac20f
commit d0ea69b61b
3 changed files with 15 additions and 4 deletions

View File

@ -94,7 +94,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 GmDebug "" $ (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

View File

@ -78,6 +78,17 @@ gmLog level loc' doc = do
gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)]) gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)])
-- | Appends a collection of logs to the logging environment, with effects
-- | if their log level specifies it should
gmLog' :: (MonadIO m, GmLog m, GmOut m) => GhcModLog -> m ()
gmLog' newLog@ GhcModLog { gmLogMessages } = do
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
gmLog GmVomit "" $ doc <+>: text content gmLog GmVomit "" $ doc <+>: text content

View File

@ -99,8 +99,8 @@ runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \d
runGmOutT opt $ runGmOutT opt $
withGhcModEnv dir' opt $ \(env,lg) -> withGhcModEnv dir' opt $ \(env,lg) ->
first (fst <$>) <$> runGhcModT' env defaultGhcModState first (fst <$>) <$> runGhcModT' env defaultGhcModState
( gmlJournal lg >> (gmSetLogLevel (ooptLogLevel $ optOutput opt) >>
gmSetLogLevel (ooptLogLevel $ optOutput opt) >> gmLog' 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