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

View File

@ -20,14 +20,10 @@ module Language.Haskell.GhcMod.Target where
import Control.Arrow import Control.Arrow
import Control.Applicative import Control.Applicative
import Control.Category ((.)) import Control.Category ((.))
import Control.Monad.Reader (runReaderT)
import GHC import GHC
import GHC.Paths (libdir) import GHC.Paths (libdir)
import StaticFlags
import SysTools import SysTools
import DynFlags import DynFlags
import HscMain
import HscTypes
import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
@ -40,6 +36,7 @@ import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils as U import Language.Haskell.GhcMod.Utils as U
import Language.Haskell.GhcMod.FileMapping import Language.Haskell.GhcMod.FileMapping
import Language.Haskell.GhcMod.LightGhc
import Data.Maybe import Data.Maybe
import Data.Monoid as Monoid import Data.Monoid as Monoid
@ -60,34 +57,6 @@ import Prelude hiding ((.))
import System.Directory import System.Directory
import System.FilePath 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 :: (IOish m, GmEnv m, GmState m, GmLog m) => LightGhc a -> m a
runGmPkgGhc action = do runGmPkgGhc action = do
pkgOpts <- packageGhcOptions pkgOpts <- packageGhcOptions

View File

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

View File

@ -67,3 +67,8 @@ spec = do
_ <- system "cabal build" _ <- system "cabal build"
res <- runD $ checkSyntax ["Main.hs"] res <- runD $ checkSyntax ["Main.hs"]
res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n" 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 module HomeModuleGraphSpec where
import Language.Haskell.GhcMod.HomeModuleGraph import Language.Haskell.GhcMod.HomeModuleGraph
import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.LightGhc
import TestUtils import TestUtils
import GHC import GHC

View File

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