From f50e5229c4b45b96932fde1c8b26c0b9dc9f0188 Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Fri, 25 Apr 2014 11:08:29 +0900
Subject: [PATCH] NG contains an error.

---
 Language/Haskell/GhcMod/ErrMsg.hs |  6 +++++-
 Language/Haskell/GhcMod/Lint.hs   |  5 ++++-
 elisp/ghc-process.el              |  2 +-
 src/GHCModi.hs                    | 28 +++++++++++++++++-----------
 4 files changed, 27 insertions(+), 14 deletions(-)

diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs
index 59eb8d5..daaf0f3 100644
--- a/Language/Haskell/GhcMod/ErrMsg.hs
+++ b/Language/Haskell/GhcMod/ErrMsg.hs
@@ -4,6 +4,7 @@ module Language.Haskell.GhcMod.ErrMsg (
     LogReader
   , setLogger
   , handleErrMsg
+  , checkErrorPrefix
   ) where
 
 import Bag (Bag, bagToList)
@@ -85,9 +86,12 @@ ppMsg spn sev dflag style msg = prefix ++ cts
     cts  = showPage dflag style msg
     defaultPrefix
       | dopt Gap.dumpSplicesFlag dflag = ""
-      | otherwise                      = "Dummy:0:0:Error:"
+      | otherwise                      = checkErrorPrefix
     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
+
+checkErrorPrefix :: String
+checkErrorPrefix = "Dummy:0:0:Error:"
diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs
index c285fb5..d70baf3 100644
--- a/Language/Haskell/GhcMod/Lint.hs
+++ b/Language/Haskell/GhcMod/Lint.hs
@@ -1,6 +1,8 @@
 module Language.Haskell.GhcMod.Lint where
 
 import Control.Applicative ((<$>))
+import Control.Exception (handle, SomeException(..))
+import Language.Haskell.GhcMod.ErrMsg (checkErrorPrefix)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.HLint (hlint)
 
@@ -9,7 +11,8 @@ import Language.Haskell.HLint (hlint)
 lintSyntax :: Options
            -> FilePath  -- ^ A target file.
            -> IO String
-lintSyntax opt file = pack <$> hlint (file : "--quiet" : hopts)
+lintSyntax opt file = handle handler $ pack <$> hlint (file : "--quiet" : hopts)
   where
     pack = convert opt . map (init . show) -- init drops the last \n.
     hopts = hlintOpts opt
+    handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el
index 0149dd5..985b9ca 100644
--- a/elisp/ghc-process.el
+++ b/elisp/ghc-process.el
@@ -72,7 +72,7 @@
     (goto-char (point-max))
     (insert string)
     (forward-line -1)
-    (when (looking-at "^\\(OK\\|NG\\)$")
+    (when (looking-at "^OK$\\|^NG ")
       (if ghc-process-hook (funcall ghc-process-hook))
       (goto-char (point-min))
       (funcall ghc-process-callback)
diff --git a/src/GHCModi.hs b/src/GHCModi.hs
index 29a3cea..37138d5 100644
--- a/src/GHCModi.hs
+++ b/src/GHCModi.hs
@@ -103,8 +103,13 @@ main = E.handle cmdHandler $
       where
         -- this is just in case.
         -- If an error is caught here, it is a bug of GhcMod library.
-        someHandler (SomeException _) = do
-            putStrLn "NG"
+        someHandler (SomeException e) = do
+            putStrLn $ "NG " ++ replace (show e)
+
+replace :: String -> String
+replace [] = []
+replace ('\n':xs) = ';' : replace xs
+replace (x:xs)    =  x  : replace xs
 
 ----------------------------------------------------------------
 
@@ -138,9 +143,14 @@ loop opt set mvar readLog  = do
         "type"   -> showType opt set arg readLog
         "boot"   -> bootIt   opt set
         "browse" -> browseIt opt set arg
-        _        -> return ([], False, set)
-    liftIO $ putStr ret
-    liftIO $ putStrLn $ if ok then "OK" else "NG"
+        "quit"   -> return ("quit", False, set)
+        ""       -> return ("quit", False, set)
+        _        -> return ([], True, set)
+    if ok then do
+        liftIO $ putStr ret
+        liftIO $ putStrLn "OK"
+      else do
+        liftIO $ putStrLn $ "NG " ++ replace ret
     liftIO $ hFlush stdout
     when ok $ loop opt set' mvar readLog
 
@@ -167,7 +177,7 @@ checkStx opt set file readLog = do
     handler :: SourceError -> Ghc (String, Bool, Set FilePath)
     handler err = do
         ret <- handleErrMsg opt err
-        return (ret, False, set)
+        return (ret, True, set)
     removeMainTarget = do
         mx <- find isMain <$> G.getModuleGraph
         case mx of
@@ -194,17 +204,13 @@ findSym opt set sym mvar = do
 
 lintStx :: Options -> Set FilePath -> FilePath
         -> Ghc (String, Bool, Set FilePath)
-lintStx opt set optFile = liftIO $ E.handle handler $ do
+lintStx opt set optFile = liftIO $ do
     ret <-lintSyntax opt' file
     return (ret, True, set)
   where
     (opts,file) = parseLintOptions optFile
     hopts = if opts == "" then [] else read opts
     opt' = opt { hlintOpts = hopts }
-    -- let's continue the session
-    handler (SomeException e) = do
-        print e
-        return ("", True, set)
 
 -- |
 -- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"