withLogger handles errors.

This commit is contained in:
Kazu Yamamoto 2014-04-28 13:52:28 +09:00
parent 000076223f
commit fc570551a2
4 changed files with 23 additions and 27 deletions

View File

@ -5,7 +5,7 @@ module Language.Haskell.GhcMod.Check (
, expand
) where
import Exception (ghandle)
import Control.Applicative ((<$>))
import GHC (Ghc)
import Language.Haskell.GhcMod.ErrMsg
import Language.Haskell.GhcMod.GHCApi
@ -23,7 +23,7 @@ checkSyntax :: Options
checkSyntax _ _ [] = return ""
checkSyntax opt cradle files = withGHC sessionName $ do
initializeFlagsWithCradle opt cradle
check opt files
either id id <$> check opt files
where
sessionName = case files of
[file] -> file
@ -35,9 +35,9 @@ checkSyntax opt cradle files = withGHC sessionName $ do
-- Warnings and errors are returned.
check :: Options
-> [FilePath] -- ^ The target files.
-> Ghc String
check opt fileNames = ghandle (handleErrMsg opt) $
withLogger opt setAllWaringFlags $ setTargetFiles fileNames
-> Ghc (Either String String)
check opt fileNames = withLogger opt setAllWaringFlags $
setTargetFiles fileNames
----------------------------------------------------------------
@ -49,7 +49,7 @@ expandTemplate :: Options
expandTemplate _ _ [] = return ""
expandTemplate opt cradle files = withGHC sessionName $ do
initializeFlagsWithCradle opt cradle
expand opt files
either id id <$> expand opt files
where
sessionName = case files of
[file] -> file
@ -60,7 +60,6 @@ expandTemplate opt cradle files = withGHC sessionName $ do
-- | Expanding Haskell Template.
expand :: Options
-> [FilePath] -- ^ The target files.
-> Ghc String
expand opt fileNames = ghandle (handleErrMsg opt) $
withDynFlags Gap.setDumpSplices $
withLogger opt setNoWaringFlags $ setTargetFiles fileNames
-> Ghc (Either String String)
expand opt fileNames = withLogger opt (Gap.setDumpSplices . setNoWaringFlags) $
setTargetFiles fileNames

View File

@ -13,6 +13,7 @@ import CoreMonad (liftIO)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.Maybe (fromMaybe)
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
import Exception (ghandle)
import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError))
import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages)
@ -50,24 +51,24 @@ appendLogRef df (LogRef ref) _ sev src style msg = do
----------------------------------------------------------------
withLogger :: Options -> (DynFlags -> DynFlags) -> Ghc () -> Ghc String
withLogger opt setDF body = do
withLogger :: Options -> (DynFlags -> DynFlags) -> Ghc () -> Ghc (Either String String)
withLogger opt setDF body = ghandle (handleErrMsg opt) $ do
logref <- liftIO $ newLogRef
withDynFlags (setLogger logref . setDF) $ do
body
liftIO $ readAndClearLogRef opt logref
liftIO $ Right <$> readAndClearLogRef opt logref
where
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
----------------------------------------------------------------
-- | Converting 'SourceError' to 'String'.
handleErrMsg :: Options -> SourceError -> Ghc String
handleErrMsg :: Options -> SourceError -> Ghc (Either String String)
handleErrMsg opt err = do
dflag <- G.getSessionDynFlags
style <- getStyle
let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err
return ret
return (Left ret)
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList

View File

@ -21,10 +21,10 @@ module Language.Haskell.GhcMod.Internal (
, getDynamicFlags
-- * Initializing 'DynFlags'
, initializeFlagsWithCradle
-- * 'Ghc' Monad
-- * Targets
, setTargetFiles
, addTargetFiles
, handleErrMsg
-- * Logging
, withLogger
, setNoWaringFlags
, setAllWaringFlags

View File

@ -168,16 +168,12 @@ checkStx :: Options
-> FilePath
-> Ghc (String, Bool, Set FilePath)
checkStx opt set file = do
GE.ghandle handler $ do
(set',add) <- removeMainTarget file set
let files = if add then [file] else []
ret <- withLogger opt setAllWaringFlags $ addTargetFiles files
return (ret, True, set')
where
handler :: SourceError -> Ghc (String, Bool, Set FilePath)
handler err = do
ret <- handleErrMsg opt err
return (ret, True, set)
eret <- withLogger opt setAllWaringFlags $ addTargetFiles files
case eret of
Right ret -> return (ret, True, set')
Left ret -> return (ret, True, set) -- fxime: set
removeMainTarget :: FilePath -> Set FilePath -> Ghc (Set FilePath, Bool)
removeMainTarget file set = do