Put line-prefix'es on exceptions too

This commit is contained in:
Daniel Gröber 2015-08-14 05:57:33 +02:00
parent f998c63c73
commit 55bf578b87
4 changed files with 48 additions and 21 deletions

View File

@ -61,6 +61,8 @@ module Language.Haskell.GhcMod (
, gmErrStr
, gmPutStrLn
, gmErrStrLn
, gmUnsafePutStrLn
, gmUnsafeErrStrLn
) where
import Language.Haskell.GhcMod.Boot

View File

@ -53,6 +53,9 @@ module Language.Haskell.GhcMod.Internal (
, GmComponentType(..)
, GmModuleGraph(..)
, prepareCabalHelper
-- * Misc stuff
, GHandler(..)
, gcatches
) where
import GHC.Paths (libdir)

View File

@ -22,6 +22,8 @@ module Language.Haskell.GhcMod.Output (
, gmErrStr
, gmPutStrLn
, gmErrStrLn
, gmUnsafePutStrLn
, gmUnsafeErrStrLn
, gmReadProcess
, stdoutGateway
) where
@ -60,20 +62,29 @@ toGmLines "" = GmLines GmPartial ""
toGmLines s | isNewline (last s) = GmLines GmTerminated s
toGmLines s = GmLines GmPartial s
outputFns :: (GmEnv m, MonadIO m') => m (GmLines String -> m' (), GmLines String -> m' ())
outputFns :: (GmEnv m, MonadIO m')
=> m (GmLines String -> m' (), GmLines String -> m' ())
outputFns = do
GhcModEnv {..} <- gmeAsk
let Options {..} = gmOptions
opts <- options
env <- gmeAsk
return $ outputFns' opts (gmOutput env)
let pfx f = withLines f
outputFns' :: MonadIO m'
=> Options
-> GmOutput
-> (GmLines String -> m' (), GmLines String -> m' ())
outputFns' opts output = let
Options {..} = opts
let outPfx, errPfx :: GmLines String -> GmLines String
pfx f = withLines f
outPfx, errPfx :: GmLines String -> GmLines String
(outPfx, errPfx) =
case linePrefix of
Nothing -> ( id, id )
Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
return $ case gmOutput of
in
case output of
GmOutputStdio ->
( liftIO . putStr . unGmLine . outPfx
, liftIO . hPutStr stderr . unGmLine . errPfx)
@ -95,6 +106,12 @@ gmErrStr str = do
putErr <- snd `liftM` outputFns
putErr $ toGmLines str
-- | Only use these when you're sure there are no other writers on stdout
gmUnsafePutStrLn, gmUnsafeErrStrLn
:: MonadIO m => Options -> String -> m ()
gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines
gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines
gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String)
gmReadProcess = do
GhcModEnv {..} <- gmeAsk
@ -177,6 +194,6 @@ withForkWait async body = do
processFailedException :: String -> String -> [String] -> Int -> IO a
processFailedException fn exe args rv =
error $ concat [fn, ": ", exe, " "
error $ concat [ fn, ": ", exe, " "
, intercalate " " (map show args)
, " (exit " ++ show rv ++ ")"]

View File

@ -23,7 +23,7 @@ import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
removeDirectoryRecursive)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush)
import System.IO (stdout, hSetEncoding, utf8, hFlush)
import System.Exit (exitSuccess)
import Text.PrettyPrint
import Prelude
@ -327,20 +327,21 @@ data InteractiveOptions = InteractiveOptions {
ghcModExtensions :: Bool
}
handler :: IO a -> IO a
handler = flip catches $
[ Handler $ \(FatalError msg) -> exitError msg
, Handler $ \(InvalidCommandLine e) -> do
handler :: IOish m => GhcModT m a -> GhcModT m a
handler = flip gcatches $
[ GHandler $ \(FatalError msg) -> exitError msg
, GHandler $ \(InvalidCommandLine e) -> do
case e of
Left cmd ->
exitError $ "Usage for `"++cmd++"' command:\n\n"
++ (cmdUsage cmd usage) ++ "\n"
++ "ghc-mod: Invalid command line form."
Right msg -> exitError $ "ghc-mod: " ++ msg
, GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
]
main :: IO ()
main = handler $ do
main = do
hSetEncoding stdout utf8
args <- getArgs
case parseGlobalArgs args of
@ -348,7 +349,7 @@ main = handler $ do
Right res -> progMain res
progMain :: (Options,[String]) -> IO ()
progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ do
progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
case globalCommands cmdArgs of
Just s -> gmPutStr s
Nothing -> ghcCommands cmdArgs
@ -359,7 +360,7 @@ progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ do
Right _ ->
return ()
Left ed ->
exitError $ renderStyle ghcModStyle (gmeDoc ed)
exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed)
globalCommands :: [String] -> Maybe String
globalCommands (cmd:_)
@ -471,8 +472,12 @@ newtype InvalidCommandLine = InvalidCommandLine (Either String String)
deriving (Show, Typeable)
instance Exception InvalidCommandLine
exitError :: String -> IO a
exitError msg = hPutStrLn stderr (dropWhileEnd (=='\n') msg) >> exitFailure
exitError :: IOish m => String -> GhcModT m a
exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' :: Options -> String -> IO a
exitError' opts msg =
gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s