NG contains an error.

This commit is contained in:
Kazu Yamamoto 2014-04-25 11:08:29 +09:00
parent 17b80ccc2f
commit f50e5229c4
4 changed files with 27 additions and 14 deletions

View File

@ -4,6 +4,7 @@ module Language.Haskell.GhcMod.ErrMsg (
LogReader LogReader
, setLogger , setLogger
, handleErrMsg , handleErrMsg
, checkErrorPrefix
) where ) where
import Bag (Bag, bagToList) import Bag (Bag, bagToList)
@ -85,9 +86,12 @@ ppMsg spn sev dflag style msg = prefix ++ cts
cts = showPage dflag style msg cts = showPage dflag style msg
defaultPrefix defaultPrefix
| dopt Gap.dumpSplicesFlag dflag = "" | dopt Gap.dumpSplicesFlag dflag = ""
| otherwise = "Dummy:0:0:Error:" | otherwise = checkErrorPrefix
prefix = fromMaybe defaultPrefix $ do prefix = fromMaybe defaultPrefix $ do
(line,col,_,_) <- Gap.getSrcSpan spn (line,col,_,_) <- Gap.getSrcSpan spn
file <- normalise <$> Gap.getSrcFile spn file <- normalise <$> Gap.getSrcFile spn
let severityCaption = Gap.showSeverityCaption sev let severityCaption = Gap.showSeverityCaption sev
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
checkErrorPrefix :: String
checkErrorPrefix = "Dummy:0:0:Error:"

View File

@ -1,6 +1,8 @@
module Language.Haskell.GhcMod.Lint where module Language.Haskell.GhcMod.Lint where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (handle, SomeException(..))
import Language.Haskell.GhcMod.ErrMsg (checkErrorPrefix)
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.HLint (hlint) import Language.Haskell.HLint (hlint)
@ -9,7 +11,8 @@ import Language.Haskell.HLint (hlint)
lintSyntax :: Options lintSyntax :: Options
-> FilePath -- ^ A target file. -> FilePath -- ^ A target file.
-> IO String -> IO String
lintSyntax opt file = pack <$> hlint (file : "--quiet" : hopts) lintSyntax opt file = handle handler $ pack <$> hlint (file : "--quiet" : hopts)
where where
pack = convert opt . map (init . show) -- init drops the last \n. pack = convert opt . map (init . show) -- init drops the last \n.
hopts = hlintOpts opt hopts = hlintOpts opt
handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"

View File

@ -72,7 +72,7 @@
(goto-char (point-max)) (goto-char (point-max))
(insert string) (insert string)
(forward-line -1) (forward-line -1)
(when (looking-at "^\\(OK\\|NG\\)$") (when (looking-at "^OK$\\|^NG ")
(if ghc-process-hook (funcall ghc-process-hook)) (if ghc-process-hook (funcall ghc-process-hook))
(goto-char (point-min)) (goto-char (point-min))
(funcall ghc-process-callback) (funcall ghc-process-callback)

View File

@ -103,8 +103,13 @@ main = E.handle cmdHandler $
where where
-- this is just in case. -- this is just in case.
-- If an error is caught here, it is a bug of GhcMod library. -- If an error is caught here, it is a bug of GhcMod library.
someHandler (SomeException _) = do someHandler (SomeException e) = do
putStrLn "NG" 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 "type" -> showType opt set arg readLog
"boot" -> bootIt opt set "boot" -> bootIt opt set
"browse" -> browseIt opt set arg "browse" -> browseIt opt set arg
_ -> return ([], False, set) "quit" -> return ("quit", False, set)
liftIO $ putStr ret "" -> return ("quit", False, set)
liftIO $ putStrLn $ if ok then "OK" else "NG" _ -> return ([], True, set)
if ok then do
liftIO $ putStr ret
liftIO $ putStrLn "OK"
else do
liftIO $ putStrLn $ "NG " ++ replace ret
liftIO $ hFlush stdout liftIO $ hFlush stdout
when ok $ loop opt set' mvar readLog 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 :: SourceError -> Ghc (String, Bool, Set FilePath)
handler err = do handler err = do
ret <- handleErrMsg opt err ret <- handleErrMsg opt err
return (ret, False, set) return (ret, True, set)
removeMainTarget = do removeMainTarget = do
mx <- find isMain <$> G.getModuleGraph mx <- find isMain <$> G.getModuleGraph
case mx of case mx of
@ -194,17 +204,13 @@ findSym opt set sym mvar = do
lintStx :: Options -> Set FilePath -> FilePath lintStx :: Options -> Set FilePath -> FilePath
-> Ghc (String, Bool, Set 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 ret <-lintSyntax opt' file
return (ret, True, set) return (ret, True, set)
where where
(opts,file) = parseLintOptions optFile (opts,file) = parseLintOptions optFile
hopts = if opts == "" then [] else read opts hopts = if opts == "" then [] else read opts
opt' = opt { hlintOpts = hopts } 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" -- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"