Fixing a bug of TH expansion for GHC 7.6 (#92).

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
+ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
-    (line,col,_,_) <- Gap.getSrcSpan spn
-    file <- normalise <$> Gap.getSrcFile spn
-    let severityCaption = Gap.showSeverityCaption sev
-    return $ file ++ ":" ++ show line ++ ":"
-                  ++ show col ++ ":" ++ severityCaption ++ 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
 
 ----------------------------------------------------------------
 

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

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`)
+            

test/data/Mutual1.hs

@@ -0,0 +1,3 @@
+module Mutual1 where
+
+import Mutual2

test/data/Mutual2.hs

@@ -0,0 +1,3 @@
+module Mutual2 where
+
+import Mutual1