Change some logging stuff
This commit is contained in:
parent
d11b12676e
commit
0f1e653f7f
@ -64,7 +64,9 @@ types file lineNo colNo =
|
|||||||
|
|
||||||
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
|
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
|
||||||
where
|
where
|
||||||
handler (SomeException _) = return []
|
handler (SomeException ex) = do
|
||||||
|
gmLog GmException "types" $ showDoc ex
|
||||||
|
return []
|
||||||
|
|
||||||
getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
|
getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
|
||||||
getSrcSpanType modSum lineNo colNo = do
|
getSrcSpanType modSum lineNo colNo = do
|
||||||
|
@ -57,16 +57,16 @@ decreaseLogLevel l = pred l
|
|||||||
-- False
|
-- False
|
||||||
gmLog :: (MonadIO m, GmLog m) => GmLogLevel -> String -> Doc -> m ()
|
gmLog :: (MonadIO m, GmLog m) => GmLogLevel -> String -> Doc -> m ()
|
||||||
gmLog level loc' doc = do
|
gmLog level loc' doc = do
|
||||||
GhcModLog { gmLogLevel = level' } <- gmlHistory
|
GhcModLog { gmLogLevel = Just level' } <- gmlHistory
|
||||||
|
|
||||||
let loc | loc' == "" = empty
|
let loc | loc' == "" = empty
|
||||||
| otherwise = text loc' <+>: empty
|
| otherwise = text loc' <+>: empty
|
||||||
msg = gmRenderDoc $ gmLogLevelDoc level <+>: sep [loc, doc]
|
msgDoc = gmLogLevelDoc level <+>: sep [loc, doc]
|
||||||
msg' = dropWhileEnd isSpace msg
|
msg = dropWhileEnd isSpace $ gmRenderDoc msgDoc
|
||||||
|
|
||||||
when (Just level <= level') $
|
when (level <= level') $ liftIO $ hPutStrLn stderr msg
|
||||||
liftIO $ hPutStrLn stderr msg'
|
|
||||||
gmlJournal (GhcModLog Nothing [(level, render loc, msg)])
|
gmlJournal (GhcModLog Nothing [(level, loc', msgDoc)])
|
||||||
|
|
||||||
newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }
|
newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }
|
||||||
deriving (Functor, Applicative, Monad)
|
deriving (Functor, Applicative, Monad)
|
||||||
|
@ -101,6 +101,7 @@ import Data.Maybe
|
|||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Distribution.Helper
|
import Distribution.Helper
|
||||||
|
import Text.PrettyPrint (Doc)
|
||||||
|
|
||||||
import qualified MonadUtils as GHC (MonadIO(..))
|
import qualified MonadUtils as GHC (MonadIO(..))
|
||||||
|
|
||||||
@ -111,8 +112,8 @@ data GhcModEnv = GhcModEnv {
|
|||||||
|
|
||||||
data GhcModLog = GhcModLog {
|
data GhcModLog = GhcModLog {
|
||||||
gmLogLevel :: Maybe GmLogLevel,
|
gmLogLevel :: Maybe GmLogLevel,
|
||||||
gmLogMessages :: [(GmLogLevel, String, String)]
|
gmLogMessages :: [(GmLogLevel, String, Doc)]
|
||||||
} deriving (Eq, Show, Read)
|
} deriving (Show)
|
||||||
|
|
||||||
instance Monoid GhcModLog where
|
instance Monoid GhcModLog where
|
||||||
mempty = GhcModLog (Just GmPanic) mempty
|
mempty = GhcModLog (Just GmPanic) mempty
|
||||||
|
@ -78,7 +78,7 @@ runE = runErrorT
|
|||||||
runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a
|
runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a
|
||||||
runNullLog action = do
|
runNullLog action = do
|
||||||
(a,w) <- runJournalT action
|
(a,w) <- runJournalT action
|
||||||
when (w /= mempty) $ liftIO $ print w
|
liftIO $ print w
|
||||||
return a
|
return a
|
||||||
|
|
||||||
shouldReturnError :: Show a
|
shouldReturnError :: Show a
|
||||||
|
Loading…
Reference in New Issue
Block a user