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"