From fdbecdddce6583df81f84c3f8a7ef15eba3b3b84 Mon Sep 17 00:00:00 2001
From: Alejandro Serrano <trupill@gmail.com>
Date: Thu, 14 Aug 2014 20:51:49 +0200
Subject: [PATCH] Make better check in presence of typed holes

---
 Language/Haskell/GhcMod/Check.hs  | 12 +++--
 Language/Haskell/GhcMod/Logger.hs | 83 ++++++++++++++++++++++++-------
 2 files changed, 73 insertions(+), 22 deletions(-)

diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs
index ea2e28a..f45015e 100644
--- a/Language/Haskell/GhcMod/Check.hs
+++ b/Language/Haskell/GhcMod/Check.hs
@@ -36,10 +36,14 @@ checkSyntax files = withErrorHandler sessionName $
 check :: IOish m
       => [FilePath]  -- ^ The target files.
       -> GhcModT m (Either String String)
-check fileNames = overrideGhcUserOptions $ \ghcOpts ->
-  withLogger (setAllWaringFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
-    _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
-    setTargetFiles fileNames
+check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
+  withLoggerTwice
+    setAllWaringFlags
+    (do _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
+        setTargetFiles fileNames)
+    (setAllWaringFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles)
+    (do _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
+        setTargetFiles fileNames)
 
 ----------------------------------------------------------------
 
diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs
index 9e78fb5..846f7cd 100644
--- a/Language/Haskell/GhcMod/Logger.hs
+++ b/Language/Haskell/GhcMod/Logger.hs
@@ -2,14 +2,15 @@
 
 module Language.Haskell.GhcMod.Logger (
     withLogger
+  , withLoggerTwice
   , checkErrorPrefix
   ) where
 
-import Bag (Bag, bagToList)
+import Bag (Bag, bagToList, filterBag, unionBags)
 import Control.Applicative ((<$>))
 import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
-import Data.List (isPrefixOf)
-import Data.Maybe (fromMaybe)
+import Data.List (isPrefixOf, find)
+import Data.Maybe (fromMaybe, isJust)
 import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
 import Exception (ghandle)
 import GHC (DynFlags, SrcSpan, Severity(SevError))
@@ -71,20 +72,70 @@ withLogger setDF body = ghandle sourceError $ do
   where
     setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
 
+withLoggerTwice :: IOish m
+                => (DynFlags -> DynFlags)
+                -> GhcModT m ()
+                -> (DynFlags -> DynFlags)
+                -> GhcModT m ()
+                -> GhcModT m (Either String String)
+withLoggerTwice setDF1 body1 setDF2 body2 = do
+  err1 <- ghandle sourceErrorBag $ do
+    logref <- liftIO newLogRef
+    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
+    withDynFlags (setLogger logref . setDF1) $
+        withCmdFlags wflags $ do
+            body1
+            Right <$> readAndClearLogRef logref
+  err2 <- ghandle sourceErrorBag $ do
+    logref <- liftIO newLogRef
+    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
+    withDynFlags (setLogger logref . setDF2) $
+        withCmdFlags wflags $ do
+            body2
+            Right <$> readAndClearLogRef logref
+  case (err1, err2) of
+    (Right x, Right _) -> return $ Right x
+    (Left b1, Right _) -> errBagToStr b1
+    (Right _, Left b2) -> errBagToStr b2
+    (Left b1, Left b2) -> do dflags <- G.getSessionDynFlags
+                             style <- toGhcModT getStyle
+                             let merged = mergeErrors dflags style b1 b2
+                             errBagToStr merged
+  where
+    setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
 
 ----------------------------------------------------------------
 
 -- | Converting 'SourceError' to 'String'.
 sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
-sourceError err = do
+sourceError err = errBagToStr (srcErrorMessages err)
+
+errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)
+errBagToStr err = do
     dflags <- G.getSessionDynFlags
     style <- toGhcModT getStyle
-    ret <- convert' (errBagToStrList dflags style . srcErrorMessages $ err)
+    ret <- convert' (errBagToStrList dflags style err)
     return $ Left ret
 
 errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
 errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
 
+sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) String)
+sourceErrorBag err = return $ Left (srcErrorMessages err)
+
+mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> Bag ErrMsg
+mergeErrors dflag style b1 b2 =
+  let b1List = bagToList b1
+      findInB1 = \pr2 msg2 err1 ->
+                    let pr1  = ppMsgPrefix (Gap.errorMsgSpan err1) G.SevWarning dflag style
+                        msg1 = showPage dflag style (errMsgExtraInfo err1)
+                     in pr1 == pr2 && msg1 == msg2
+      mustBeB2 = \err2 ->
+                    let pr2  = ppMsgPrefix (Gap.errorMsgSpan err2) G.SevWarning dflag style
+                        msg2 = showPage dflag style (errMsgExtraInfo err2)
+                     in not . isJust $ find (findInB1 pr2 msg2) b1List
+   in b1 `unionBags` filterBag mustBeB2 b2
+
 ----------------------------------------------------------------
 
 ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
@@ -98,22 +149,18 @@ ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
 ppMsg spn sev dflag style msg = prefix ++ cts
   where
     cts  = showPage dflag style msg
-    defaultPrefix
-      | Gap.isDumpSplices dflag = ""
-      | otherwise               = checkErrorPrefix
-    prefix = fromMaybe defaultPrefix $ do
+    prefix = ppMsgPrefix spn sev dflag style
+
+ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String
+ppMsgPrefix spn sev dflag _style =
+  let defaultPrefix
+        | Gap.isDumpSplices dflag = ""
+        | otherwise               = checkErrorPrefix
+   in fromMaybe defaultPrefix $ do
         (line,col,_,_) <- Gap.getSrcSpan spn
         file <- normalise <$> Gap.getSrcFile spn
         let severityCaption = Gap.showSeverityCaption sev
-            pref0
-              | typeWarning1 `isPrefixOf` cts ||
-                typeWarning2 `isPrefixOf` cts = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
-              | otherwise                     = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
-        return pref0
-    -- DeferTypeErrors turns a type error to a warning.
-    -- So, let's turns it the error again.
-    typeWarning1 = "Couldn't match expected type"
-    typeWarning2 = "Couldn't match type"
+        return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
 
 checkErrorPrefix :: String
 checkErrorPrefix = "Dummy:0:0:Error:"