From bb3a948912bd91f41cbd528533ff3a0aa2dc9050 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 18 Aug 2015 07:41:08 +0200 Subject: [PATCH] Fix over-qualified error messages (Fix #551) --- Language/Haskell/GhcMod/LightGhc.hs | 44 +++++++++++++++ Language/Haskell/GhcMod/Logger.hs | 84 ++++++++++++++--------------- Language/Haskell/GhcMod/Target.hs | 33 +----------- ghc-mod.cabal | 1 + test/CheckSpec.hs | 5 ++ test/HomeModuleGraphSpec.hs | 2 +- test/TargetSpec.hs | 1 + 7 files changed, 95 insertions(+), 75 deletions(-) create mode 100644 Language/Haskell/GhcMod/LightGhc.hs diff --git a/Language/Haskell/GhcMod/LightGhc.hs b/Language/Haskell/GhcMod/LightGhc.hs new file mode 100644 index 0000000..18aac05 --- /dev/null +++ b/Language/Haskell/GhcMod/LightGhc.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 5423c52..fc3ca6e 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -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 + let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref + handlers = [ + GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe, + GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex] + ] + gpe = GmPprEnv { + gpeDynFlags = hsc_dflags env , gpeMapFile = rfm } - setLogger df = Gap.setLogAction df $ appendLogRef st df logref - handlers = [ - GHandler $ \ex -> return $ Left $ runReader (sourceError ex) st, - GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex] - ] - 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 diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 150fbbd..de73b13 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 105a1f5..bb579b7 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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 diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index cc9b219..251de2b 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -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" diff --git a/test/HomeModuleGraphSpec.hs b/test/HomeModuleGraphSpec.hs index 7e43140..e8918cc 100644 --- a/test/HomeModuleGraphSpec.hs +++ b/test/HomeModuleGraphSpec.hs @@ -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 diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs index 9207b65..fda45a2 100644 --- a/test/TargetSpec.hs +++ b/test/TargetSpec.hs @@ -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