hasufell
/
ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Also catch exceptions thrown in IO

This commit is contained in:
Daniel Gröber 2015-09-01 04:14:15 +02:00
parent 99ed6a94f1
commit 2af1da960b
3 changed files with 16 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Language/Haskell/GhcMod.hs
View File

@ -62,8 +62,8 @@ module Language.Haskell.GhcMod (
, gmErrStr , gmErrStr
, gmPutStrLn , gmPutStrLn
, gmErrStrLn , gmErrStrLn
, gmUnsafePutStrLn , gmUnsafePutStr
, gmUnsafeErrStrLn , gmUnsafeErrStr
-- * FileMapping -- * FileMapping
, loadMappedFile , loadMappedFile
, loadMappedFileSource , loadMappedFileSource

10
Language/Haskell/GhcMod/Output.hs
View File

@ -23,8 +23,8 @@ module Language.Haskell.GhcMod.Output (
, gmPutStrLn , gmPutStrLn
, gmErrStrLn , gmErrStrLn
, gmReadProcess , gmReadProcess
, gmUnsafePutStrLn , gmUnsafePutStr
, gmUnsafeErrStrLn , gmUnsafeErrStr
, gmUnsafeReadProcess , gmUnsafeReadProcess
, stdoutGateway , stdoutGateway
) where ) where
@ -109,10 +109,10 @@ gmErrStr str = do
putErr $ toGmLines str putErr $ toGmLines str
-- | Only use these when you're sure there are no other writers on stdout -- | Only use these when you're sure there are no other writers on stdout
gmUnsafePutStrLn, gmUnsafeErrStrLn gmUnsafePutStr, gmUnsafeErrStr
:: MonadIO m => OutputOpts -> String -> m () :: MonadIO m => OutputOpts -> String -> m ()
gmUnsafePutStrLn oopts = (fst $ outputFns' oopts GmOutputStdio) . toGmLines gmUnsafePutStr oopts = (fst $ outputFns' oopts GmOutputStdio) . toGmLines
gmUnsafeErrStrLn oopts = (snd $ outputFns' oopts GmOutputStdio) . toGmLines gmUnsafeErrStr oopts = (snd $ outputFns' oopts GmOutputStdio) . toGmLines
gmUnsafeReadProcess :: OutputOpts -> FilePath -> [String] -> String -> IO String gmUnsafeReadProcess :: OutputOpts -> FilePath -> [String] -> String -> IO String
gmUnsafeReadProcess oopts = gmUnsafeReadProcess oopts =

14
src/GHCMod.hs
View File

@ -25,7 +25,7 @@ import System.FilePath ((</>))
import System.Directory (setCurrentDirectory, getAppUserDataDirectory, import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
removeDirectoryRecursive) removeDirectoryRecursive)
import System.Environment (getArgs) import System.Environment (getArgs)
import System.IO (stdout, hSetEncoding, utf8, hFlush) import System.IO
import System.Exit import System.Exit
import Text.PrettyPrint import Text.PrettyPrint
import Prelude hiding ((.)) import Prelude hiding ((.))
@ -396,7 +396,10 @@ main = do
args <- getArgs args <- getArgs
case parseGlobalArgs args of case parseGlobalArgs args of
Left e -> throw e Left e -> throw e
Right res -> progMain res Right res@(globalOptions,_) -> catches (progMain res) [
Handler $ \(e :: GhcModError) ->
exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc e)
]
progMain :: (Options,[String]) -> IO () progMain :: (Options,[String]) -> IO ()
progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
@ -407,7 +410,7 @@ progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $
ghcCommands cmdArgs ghcCommands cmdArgs
where where
hndle action = do hndle action = do
(e, _l) <- action (e, _l) <- liftIO . evaluate =<< action
case e of case e of
Right _ -> Right _ ->
return () return ()
@ -555,8 +558,9 @@ exitError :: IOish m => String -> GhcModT m a
exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' :: Options -> String -> IO a exitError' :: Options -> String -> IO a
exitError' opts msg = exitError' opts msg = do
gmUnsafeErrStrLn (outputOpts opts) (dropWhileEnd (=='\n') msg) >> liftIO exitFailure gmUnsafeErrStr (outputOpts opts) msg
liftIO exitFailure
fatalError :: String -> a fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s fatalError s = throw $ FatalError $ "ghc-mod: " ++ s