Fix over-qualified error messages (Fix #551)

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

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

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

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

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"

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

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