Fix over-qualified error messages (Fix #551)

This commit is contained in:
Daniel Gröber 2015-08-18 07:41:08 +02:00
parent 90b1e452e2
commit bb3a948912
7 changed files with 95 additions and 75 deletions

View File

@ -0,0 +1,44 @@
module Language.Haskell.GhcMod.LightGhc where
import Control.Monad.Reader (runReaderT)
import Data.IORef
import GHC
import GHC.Paths (libdir)
import StaticFlags
import SysTools
import DynFlags
import HscMain
import HscTypes
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.DynFlags
withLightHscEnv :: forall m a. IOish m
=> [GHCOption] -> (HscEnv -> m a) -> m a
withLightHscEnv opts action = gbracket initEnv teardownEnv action
where
teardownEnv :: HscEnv -> m ()
teardownEnv env = liftIO $ do
let dflags = hsc_dflags env
cleanTempFiles dflags
cleanTempDirs dflags
initEnv :: m HscEnv
initEnv = liftIO $ do
initStaticOpts
settings <- initSysTools (Just libdir)
dflags <- initDynFlags (defaultDynFlags settings)
env <- newHscEnv dflags
dflags' <- runLightGhc env $ do
-- HomeModuleGraph and probably all other clients get into all sorts of
-- trouble if the package state isn't initialized here
_ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags
getSessionDynFlags
newHscEnv dflags'
runLightGhc :: HscEnv -> LightGhc a -> IO a
runLightGhc env action = do
renv <- newIORef env
flip runReaderT renv $ unLightGhc action

View File

@ -8,15 +8,17 @@ module Language.Haskell.GhcMod.Logger (
import Control.Arrow
import Control.Applicative
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import Data.Ord
import Data.List
import Data.Maybe
import Data.Function
import Control.Monad.Reader (Reader, asks, runReader)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import System.FilePath (normalise)
import Text.PrettyPrint
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
import GHC (DynFlags, SrcSpan, Severity(SevError))
import ErrUtils
import GHC
import HscTypes
import Outputable
import qualified GHC as G
@ -38,7 +40,6 @@ data Log = Log [String] Builder
newtype LogRef = LogRef (IORef Log)
data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags
, gpePprStyle :: PprStyle
, gpeMapFile :: FilePath -> FilePath
}
@ -56,18 +57,23 @@ readAndClearLogRef (LogRef ref) = do
writeIORef ref emptyLog
return $ b []
appendLogRef :: GmPprEnv -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef rs df (LogRef ref) _ sev src st msg = modifyIORef ref update
appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef rfm df (LogRef ref) _ sev src st msg = do
modifyIORef ref update
where
l = runReader (ppMsg src sev msg) rs{gpeDynFlags=df, gpePprStyle=st}
gpe = GmPprEnv {
gpeDynFlags = df
, gpeMapFile = rfm
}
l = runReader (ppMsg st src sev msg) gpe
update lg@(Log ls b)
| l `elem` ls = lg
| otherwise = Log (l:ls) (b . (l:))
----------------------------------------------------------------
-- | Set the session flag (e.g. "-Wall" or "-w:") then
-- executes a body. Logged messages are returned as 'String'.
-- | Logged messages are returned as 'String'.
-- Right is success and Left is failure.
withLogger :: (GmGhc m, GmEnv m, GmState m)
=> (DynFlags -> DynFlags)
@ -88,73 +94,67 @@ withLogger' env action = do
rfm <- mkRevRedirMapFunc
let dflags = hsc_dflags env
pu = icPrintUnqual dflags (hsc_IC env)
stl = mkUserStyle pu AllTheWay
st = GmPprEnv {
gpeDynFlags = dflags
, gpePprStyle = stl
, gpeMapFile = rfm
}
setLogger df = Gap.setLogAction df $ appendLogRef st df logref
let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref
handlers = [
GHandler $ \ex -> return $ Left $ runReader (sourceError ex) st,
GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe,
GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
]
gpe = GmPprEnv {
gpeDynFlags = hsc_dflags env
, gpeMapFile = rfm
}
a <- gcatches (Right <$> action setLogger) handlers
ls <- liftIO $ readAndClearLogRef logref
return ((,) ls <$> a)
errBagToStrList :: (Functor m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]
errBagToStrList env errs = let
dflags = hsc_dflags env
pu = icPrintUnqual dflags (hsc_IC env)
st = mkUserStyle pu AllTheWay
in do
errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]
errBagToStrList env errs = do
rfm <- mkRevRedirMapFunc
return $ runReader
(errsToStr (bagToList errs))
GmPprEnv{gpeDynFlags=dflags, gpePprStyle=st, gpeMapFile=rfm}
(errsToStr (sortMsgBag errs))
GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm }
----------------------------------------------------------------
-- | Converting 'SourceError' to 'String'.
sourceError :: SourceError -> GmPprEnvM [String]
sourceError = errsToStr . reverse . bagToList . srcErrorMessages
sourceError = errsToStr . sortMsgBag . srcErrorMessages
errsToStr :: [ErrMsg] -> GmPprEnvM [String]
errsToStr = mapM ppErrMsg
sortMsgBag :: Bag ErrMsg -> [ErrMsg]
sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag
----------------------------------------------------------------
ppErrMsg :: ErrMsg -> GmPprEnvM String
ppErrMsg err = do
dflag <- asks gpeDynFlags
st <- asks gpePprStyle
let ext = showPage dflag st (errMsgExtraInfo err)
m <- ppMsg spn SevError msg
dflags <- asks gpeDynFlags
let unqual = errMsgContext err
st = mkErrStyle dflags unqual
let ext = showPage dflags st (errMsgExtraInfo err)
m <- ppMsg st spn SevError msg
return $ m ++ (if null ext then "" else "\n" ++ ext)
where
spn = Gap.errorMsgSpan err
msg = errMsgShortDoc err
ppMsg :: SrcSpan -> Severity-> SDoc -> GmPprEnvM String
ppMsg spn sev msg = do
dflag <- asks gpeDynFlags
st <- asks gpePprStyle
let cts = showPage dflag st msg
ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String
ppMsg st spn sev msg = do
dflags <- asks gpeDynFlags
let cts = showPage dflags st msg
prefix <- ppMsgPrefix spn sev cts
return $ prefix ++ cts
ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String
ppMsgPrefix spn sev cts = do
dflag <- asks gpeDynFlags
dflags <- asks gpeDynFlags
mr <- asks gpeMapFile
let defaultPrefix
| Gap.isDumpSplices dflag = ""
| Gap.isDumpSplices dflags = ""
| otherwise = checkErrorPrefix
return $ fromMaybe defaultPrefix $ do
(line,col,_,_) <- Gap.getSrcSpan spn

View File

@ -20,14 +20,10 @@ module Language.Haskell.GhcMod.Target where
import Control.Arrow
import Control.Applicative
import Control.Category ((.))
import Control.Monad.Reader (runReaderT)
import GHC
import GHC.Paths (libdir)
import StaticFlags
import SysTools
import DynFlags
import HscMain
import HscTypes
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Monad.Types
@ -40,6 +36,7 @@ import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils as U
import Language.Haskell.GhcMod.FileMapping
import Language.Haskell.GhcMod.LightGhc
import Data.Maybe
import Data.Monoid as Monoid
@ -60,34 +57,6 @@ import Prelude hiding ((.))
import System.Directory
import System.FilePath
withLightHscEnv :: forall m a. IOish m
=> [GHCOption] -> (HscEnv -> m a) -> m a
withLightHscEnv opts action = gbracket initEnv teardownEnv action
where
teardownEnv :: HscEnv -> m ()
teardownEnv env = liftIO $ do
let dflags = hsc_dflags env
cleanTempFiles dflags
cleanTempDirs dflags
initEnv :: m HscEnv
initEnv = liftIO $ do
initStaticOpts
settings <- initSysTools (Just libdir)
dflags <- initDynFlags (defaultDynFlags settings)
env <- newHscEnv dflags
dflags' <- runLightGhc env $ do
-- HomeModuleGraph and probably all other clients get into all sorts of
-- trouble if the package state isn't initialized here
_ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags
getSessionDynFlags
newHscEnv dflags'
runLightGhc :: HscEnv -> LightGhc a -> IO a
runLightGhc env action = do
renv <- newIORef env
flip runReaderT renv $ unLightGhc action
runGmPkgGhc :: (IOish m, GmEnv m, GmState m, GmLog m) => LightGhc a -> m a
runGmPkgGhc action = do
pkgOpts <- packageGhcOptions

View File

@ -118,6 +118,7 @@ Library
Language.Haskell.GhcMod.Info
Language.Haskell.GhcMod.Lang
Language.Haskell.GhcMod.Lint
Language.Haskell.GhcMod.LightGhc
Language.Haskell.GhcMod.Logger
Language.Haskell.GhcMod.Logging
Language.Haskell.GhcMod.Modules

View File

@ -67,3 +67,8 @@ spec = do
_ <- system "cabal build"
res <- runD $ checkSyntax ["Main.hs"]
res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n"
it "Uses the right qualification style" $ do
withDirectory_ "test/data/nice-qualification" $ do
res <- runD $ checkSyntax ["NiceQualification.hs"]
res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NULIn the expression: \"wrong type\"\NULIn an equation for \8216main\8217: main = \"wrong type\"\n"

View File

@ -19,7 +19,7 @@
module HomeModuleGraphSpec where
import Language.Haskell.GhcMod.HomeModuleGraph
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.LightGhc
import TestUtils
import GHC

View File

@ -2,6 +2,7 @@
module TargetSpec where
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.LightGhc
import Language.Haskell.GhcMod.Gap
import Test.Hspec