diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 47d3205..5843dac 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -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 diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs index 1009b1d..c72f085 100644 --- a/Language/Haskell/GhcMod/ErrMsg.hs +++ b/Language/Haskell/GhcMod/ErrMsg.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index f51cf28..8f684e6 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -21,10 +21,10 @@ module Language.Haskell.GhcMod.Internal ( , getDynamicFlags -- * Initializing 'DynFlags' , initializeFlagsWithCradle - -- * 'Ghc' Monad + -- * Targets , setTargetFiles , addTargetFiles - , handleErrMsg + -- * Logging , withLogger , setNoWaringFlags , setAllWaringFlags diff --git a/src/GHCModi.hs b/src/GHCModi.hs index c71ffa0..5c9aed5 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -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) + (set',add) <- removeMainTarget file set + let files = if add then [file] else [] + 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