hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #323 from serras/master

Browse Source 
Show error messages without qualification
This commit is contained in:
Kazu Yamamoto 2014-08-15 18:38:29 +09:00
commit f7bc8460f4
1 changed files with 14 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
Language/Haskell/GhcMod/Logger.hs
View File

@ -11,7 +11,7 @@ import Control.Applicative ((<$>))
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.List (isPrefixOf, find, nub, isInfixOf) import Data.List (isPrefixOf, find, nub, isInfixOf)
import Data.Maybe (fromMaybe, isJust) import Data.Maybe (fromMaybe, isJust)
import ErrUtils (ErrMsg, WarnMsg, errMsgShortDoc, errMsgExtraInfo, mkPlainWarnMsg) import ErrUtils (ErrMsg, WarnMsg, errMsgShortDoc, errMsgExtraInfo, mkWarnMsg)
import Exception (ghandle) import Exception (ghandle)
import GHC (DynFlags, SrcSpan, Severity(SevError)) import GHC (DynFlags, SrcSpan, Severity(SevError))
import qualified GHC as G import qualified GHC as G
@ -22,7 +22,7 @@ import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert (convert') import Language.Haskell.GhcMod.Convert (convert')
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Outputable (PprStyle, SDoc) import Outputable (PprStyle, SDoc, qualName, qualModule, mkErrStyle, neverQualify)
import System.FilePath (normalise) import System.FilePath (normalise)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -73,7 +73,12 @@ readAndClearLogBagRef (LogBagRef ref) = do
appendLogBagRef :: DynFlags -> LogBagRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () appendLogBagRef :: DynFlags -> LogBagRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogBagRef df (LogBagRef ref) _ sev src style msg = modifyIORef ref update appendLogBagRef df (LogBagRef ref) _ sev src style msg = modifyIORef ref update
where where
warnMsg = mkPlainWarnMsg df src msg qstyle = (qualName style, qualModule style)
#if __GLASGOW_HASKELL__ >= 706
warnMsg = mkWarnMsg df src qstyle msg
#else
warnMsg = mkWarnMsg src qstyle msg
#endif
warnBag = consBag warnMsg emptyBag warnBag = consBag warnMsg emptyBag
update lg@(LogBag b) = let (b1,b2) = mergeErrors df style b warnBag update lg@(LogBag b) = let (b1,b2) = mergeErrors df style b warnBag
in LogBag $ b1 `unionBags` b2 in LogBag $ b1 `unionBags` b2
@ -152,7 +157,12 @@ errBagToStr' f err = do
errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a
errAndWarnBagToStr f err warn = do errAndWarnBagToStr f err warn = do
dflags <- G.getSessionDynFlags dflags <- G.getSessionDynFlags
style <- toGhcModT getStyle -- style <- toGhcModT getStyle
#if __GLASGOW_HASKELL__ >= 706
let style = mkErrStyle dflags neverQualify
#else
let style = mkErrStyle neverQualify
#endif
ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn) ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn)
return $ f ret return $ f ret