From 4a5f5441f348d3d78d18a6a77ce3ea67635e4c4a Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Sat, 16 Mar 2013 11:50:45 +0900
Subject: [PATCH] Fixing a bug of TH expansion for GHC 7.6 (#92).

---
 ErrMsg.hs            | 22 ++++++++++++++--------
 Info.hs              |  4 ++--
 test/CheckSpec.hs    | 10 +++++++++-
 test/data/Mutual1.hs |  3 +++
 test/data/Mutual2.hs |  3 +++
 5 files changed, 31 insertions(+), 11 deletions(-)
 create mode 100644 test/data/Mutual1.hs
 create mode 100644 test/data/Mutual2.hs

diff --git a/ErrMsg.hs b/ErrMsg.hs
index 0433f80..3adb962 100644
--- a/ErrMsg.hs
+++ b/ErrMsg.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE BangPatterns #-}
+
 module ErrMsg (
     LogReader
   , setLogger
@@ -32,7 +34,9 @@ setLogger True  df = do
     let newdf = Gap.setLogAction df $ appendLog ref
     return (newdf, reverse <$> readIORef ref)
   where
-    appendLog ref _ sev src _ msg = modifyIORef ref (\ls -> ppMsg src sev df msg : ls)
+    appendLog ref _ sev src _ msg = do
+        let !l = ppMsg src sev df msg
+        modifyIORef ref (\ls -> l : ls)
 
 ----------------------------------------------------------------
 
@@ -54,15 +58,17 @@ ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext
      ext = showMsg dflag (errMsgExtraInfo err)
 
 ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String
-ppMsg spn sev dflag msg = fromMaybe def $ do
-    (line,col,_,_) <- Gap.getSrcSpan spn
-    file <- normalise <$> Gap.getSrcFile spn
-    let severityCaption = Gap.showSeverityCaption sev
-    return $ file ++ ":" ++ show line ++ ":"
-                  ++ show col ++ ":" ++ severityCaption ++ cts ++ "\0"
+ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
   where
-    def = "ghc-mod:0:0:Probably mutual module import occurred\0"
     cts  = showMsg dflag msg
+    defaultPrefix
+      | dopt Opt_D_dump_splices dflag = ""
+      | otherwise                     = "Dummy:0:0:"
+    prefix = fromMaybe defaultPrefix $ do
+        (line,col,_,_) <- Gap.getSrcSpan spn
+        file <- normalise <$> Gap.getSrcFile spn
+        let severityCaption = Gap.showSeverityCaption sev
+        return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
 
 ----------------------------------------------------------------
 
diff --git a/Info.hs b/Info.hs
index 12f290d..f65cec7 100644
--- a/Info.hs
+++ b/Info.hs
@@ -144,13 +144,13 @@ inModuleContext opt cradle fileName modstr action errmsg =
     withGHCDummyFile (valid ||> invalid ||> return errmsg)
   where
     valid = do
-        void $ initializeFlagsWithCradle opt cradle ["-w"] False
+        void $ initializeFlagsWithCradle opt cradle ["-w:"] False
         setTargetFile fileName
         checkSlowAndSet
         void $ load LoadAllTargets
         doif setContextFromTarget action
     invalid = do
-        void $ initializeFlagsWithCradle opt cradle ["-w"] False
+        void $ initializeFlagsWithCradle opt cradle ["-w:"] False
         setTargetBuffer
         checkSlowAndSet
         void $ load LoadAllTargets
diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs
index a818b87..a9632ce 100644
--- a/test/CheckSpec.hs
+++ b/test/CheckSpec.hs
@@ -3,7 +3,7 @@ module CheckSpec where
 import CabalApi
 import Check
 import Cradle
-import Data.List (isSuffixOf)
+import Data.List (isSuffixOf, isInfixOf)
 import Expectation
 import Test.Hspec
 import Types
@@ -23,3 +23,11 @@ spec = do
                 cradle <- getGHCVersion >>= findCradle Nothing . fst
                 res <- checkSyntax defaultOptions cradle "test/Bar/Baz.hs"
                 res `shouldSatisfy` ("test/Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\NUL\n" `isSuffixOf`)
+
+        it "can detect mutually imported modules" $ do
+            withDirectory_ "test/data" $ do
+                (strVer,_) <- getGHCVersion
+                cradle <- findCradle Nothing strVer
+                res <- checkSyntax defaultOptions cradle "Mutual1.hs"
+                res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)
+            
\ No newline at end of file
diff --git a/test/data/Mutual1.hs b/test/data/Mutual1.hs
new file mode 100644
index 0000000..ef23310
--- /dev/null
+++ b/test/data/Mutual1.hs
@@ -0,0 +1,3 @@
+module Mutual1 where
+
+import Mutual2
diff --git a/test/data/Mutual2.hs b/test/data/Mutual2.hs
new file mode 100644
index 0000000..fb5f593
--- /dev/null
+++ b/test/data/Mutual2.hs
@@ -0,0 +1,3 @@
+module Mutual2 where
+
+import Mutual1